From 2170ee52532b6d4d88f5d989b5674d84b81d79ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Mon, 20 Nov 2023 19:15:41 +0100 Subject: [PATCH] flambda-backend: Better region handling for functions (#1871) --- lambda/lambda.ml | 15 ++-- lambda/lambda.mli | 4 ++ lambda/printlambda.ml | 5 +- lambda/simplif.ml | 20 +++--- lambda/simplif.mli | 1 + lambda/tmc.ml | 5 +- lambda/transl_list_comprehension.ml | 1 + lambda/translattribute.ml | 4 +- lambda/translclass.ml | 16 +++-- lambda/translcore.ml | 68 ++++++++++--------- lambda/translmod.ml | 2 + lambda/translprim.ml | 1 + middle_end/closure/closure.ml | 6 +- middle_end/flambda/closure_conversion.ml | 8 +-- .../tests/backtrace/backtrace_systhreads.ml | 4 +- .../lib-threads/uncaught_exception_handler.ml | 7 +- .../uncaught_exception_handler.reference | 8 +-- typing/tast_mapper.ml | 4 +- typing/typecore.ml | 4 +- typing/typedtree.ml | 1 + typing/typedtree.mli | 7 +- 21 files changed, 115 insertions(+), 76 deletions(-) diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 8afee185f8e..04dd4f50405 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -70,6 +70,11 @@ include (struct if Config.stack_allocation then Modify_maybe_stack else Modify_heap + let equal_alloc_mode mode1 mode2 = + match mode1, mode2 with + | Alloc_local, Alloc_local | Alloc_heap, Alloc_heap -> true + | (Alloc_local | Alloc_heap), _ -> false + end : sig type locality_mode = private @@ -92,6 +97,7 @@ end : sig val join_mode : alloc_mode -> alloc_mode -> alloc_mode + val equal_alloc_mode : alloc_mode -> alloc_mode -> bool end) let is_local_mode = function @@ -612,6 +618,7 @@ and lfunction = attr: function_attribute; (* specified with [@inline] attribute *) loc: scoped_location; mode: alloc_mode; + ret_mode: alloc_mode; region: bool; } and lambda_while = @@ -675,7 +682,7 @@ let max_arity () = (* 126 = 127 (the maximal number of parameters supported in C--) - 1 (the hidden parameter containing the environment) *) -let lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region = +let lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region = assert (List.length params <= max_arity ()); (* A curried function type with n parameters has n arrows. Of these, the first [n-nlocal] have return mode Heap, while the remainder @@ -698,7 +705,7 @@ let lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region = if not region then assert (nlocal >= 1); if is_local_mode mode then assert (nlocal = nparams) end; - Lfunction { kind; params; return; body; attr; loc; mode; region } + Lfunction { kind; params; return; body; attr; loc; mode; ret_mode; region } let lambda_unit = Lconst const_unit @@ -1272,9 +1279,9 @@ let shallow_map ~tail ~non_tail:f = function ap_specialised; ap_probe; } - | Lfunction { kind; params; return; body; attr; loc; mode; region } -> + | Lfunction { kind; params; return; body; attr; loc; mode; ret_mode; region } -> Lfunction { kind; params; return; body = f body; attr; loc; - mode; region } + mode; ret_mode; region } | Llet (str, layout, v, e1, e2) -> Llet (str, layout, v, f e1, tail e2) | Lmutlet (layout, v, e1, e2) -> diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 79506b418dc..863799cc225 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -56,6 +56,8 @@ val modify_heap : modify_mode val modify_maybe_stack : modify_mode +val equal_alloc_mode : alloc_mode -> alloc_mode -> bool + type initialization_or_assignment = (* [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. *) @@ -515,6 +517,7 @@ and lfunction = private attr: function_attribute; (* specified with [@inline] attribute *) loc : scoped_location; mode : alloc_mode; (* alloc mode of the closure itself *) + ret_mode: alloc_mode; region : bool; (* false if this function may locally allocate in the caller's region *) } @@ -635,6 +638,7 @@ val lfunction : attr:function_attribute -> (* specified with [@inline] attribute *) loc:scoped_location -> mode:alloc_mode -> + ret_mode:alloc_mode -> region:bool -> lambda diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 54c4db345de..b3b275892ea 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -807,7 +807,7 @@ let rec lam ppf = function apply_inlined_attribute ap.ap_inlined apply_specialised_attribute ap.ap_specialised apply_probe ap.ap_probe - | Lfunction{kind; params; return; body; attr; mode; region} -> + | Lfunction{kind; params; return; body; attr; ret_mode; mode} -> let pr_params ppf params = match kind with | Curried {nlocal} -> @@ -830,10 +830,9 @@ let rec lam ppf = function layout ppf p.layout) params; fprintf ppf ")" 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 + function_attribute attr return_kind (ret_mode, return) lam body | Llet _ | Lmutlet _ as expr -> let let_kind = begin function | Llet(str,_,_,_,_) -> diff --git a/lambda/simplif.ml b/lambda/simplif.ml index be250b5d0a6..c860d3f5db2 100644 --- a/lambda/simplif.ml +++ b/lambda/simplif.ml @@ -233,8 +233,8 @@ let simplify_exits lam = | Lapply ap -> Lapply{ap with ap_func = simplif ~layout:None ~try_depth ap.ap_func; ap_args = List.map (simplif ~layout:None ~try_depth) ap.ap_args} - | Lfunction{kind; params; return; mode; region; body = l; attr; loc} -> - lfunction ~kind ~params ~return ~mode ~region + | Lfunction{kind; params; return; mode; ret_mode; region; body = l; attr; loc} -> + lfunction ~kind ~params ~return ~mode ~region ~ret_mode ~body:(simplif ~layout:None ~try_depth l) ~attr ~loc | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2) @@ -556,12 +556,12 @@ let simplify_lets lam = | _ -> no_opt () end | Lfunction{kind=outer_kind; params; return=outer_return; body = l; - attr; loc; mode; region=outer_region} -> + attr; loc; ret_mode; mode; region=outer_region} -> begin match outer_kind, outer_region, simplif l with Curried {nlocal=0}, true, Lfunction{kind=Curried _ as kind; params=params'; return=return2; - body; attr; loc; mode=inner_mode; region} + body; attr; loc; mode=inner_mode; ret_mode; region} when optimize && List.length params + List.length params' <= Lambda.max_arity() -> (* The returned function's mode should match the outer return mode *) @@ -571,9 +571,9 @@ let simplify_lets lam = type of the merged function taking [params @ params'] as parameters is the type returned after applying [params']. *) let return = return2 in - lfunction ~kind ~params:(params @ params') ~return ~body ~attr ~loc ~mode ~region + lfunction ~kind ~params:(params @ params') ~return ~body ~attr ~loc ~mode ~ret_mode ~region | kind, region, body -> - lfunction ~kind ~params ~return:outer_return ~body ~attr ~loc ~mode ~region + lfunction ~kind ~params ~return:outer_return ~body ~attr ~loc ~mode ~ret_mode ~region end | Llet(_str, _k, v, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); @@ -759,7 +759,7 @@ and list_emit_tail_infos is_tail = function's body. *) let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body - ~attr ~loc ~mode ~region:orig_region = + ~attr ~loc ~mode ~ret_mode ~region:orig_region = let rec aux map add_region = function (* When compiling [fun ?(x=expr) -> body], this is first translated to: @@ -836,7 +836,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body let inner_fun = lfunction ~kind:(Curried {nlocal=0}) ~params:new_ids - ~return ~body ~attr ~loc ~mode ~region:true + ~return ~body ~attr ~loc ~mode ~ret_mode ~region:true in (wrapper_body, (inner_id, inner_fun)) in @@ -849,9 +849,9 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body end; let body, inner = aux [] false body in let attr = { default_stub_attribute with check = attr.check } in - [(fun_id, lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region:true); inner] + [(fun_id, lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region:true); inner] with Exit -> - [(fun_id, lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region:orig_region)] + [(fun_id, lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region:orig_region)] (* Simplify local let-bound functions: if all occurrences are fully-applied function calls in the same "tail scope", replace the diff --git a/lambda/simplif.mli b/lambda/simplif.mli index 2bcacfed5dd..7b3d2ea83f9 100644 --- a/lambda/simplif.mli +++ b/lambda/simplif.mli @@ -38,5 +38,6 @@ val split_default_wrapper -> attr:function_attribute -> loc:Lambda.scoped_location -> mode:Lambda.alloc_mode + -> ret_mode:Lambda.alloc_mode -> region:bool -> (Ident.t * lambda) list diff --git a/lambda/tmc.ml b/lambda/tmc.ml index 58280f392fc..776f2007d50 100644 --- a/lambda/tmc.ml +++ b/lambda/tmc.ml @@ -991,9 +991,9 @@ and traverse_binding outer_ctx inner_ctx (var, def) = (Debuginfo.Scoped_location.to_location lfun.loc) Warnings.Unused_tmc_attribute; let direct = - let { kind; params; return; body = _; attr; loc; mode; region } = lfun in + let { kind; params; return; body = _; attr; loc; mode; ret_mode; region } = lfun in let body = Choice.direct fun_choice in - lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region in + lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region in let dps = let dst_param = { var = Ident.create_local "dst"; @@ -1021,6 +1021,7 @@ and traverse_binding outer_ctx inner_ctx (var, def) = ~attr:lfun.attr ~loc:lfun.loc ~mode:lfun.mode + ~ret_mode:lfun.ret_mode ~region:true in let dps_var = special.dps_id in diff --git a/lambda/transl_list_comprehension.ml b/lambda/transl_list_comprehension.ml index ce5138c6065..cde1603d270 100644 --- a/lambda/transl_list_comprehension.ml +++ b/lambda/transl_list_comprehension.ml @@ -259,6 +259,7 @@ let rec translate_bindings ~attr:default_function_attribute ~loc ~mode:alloc_local + ~ret_mode:alloc_local ~region:false ~body:(add_bindings body) in diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml index 2f06ba5a6cf..5b2f112171d 100644 --- a/lambda/translattribute.ml +++ b/lambda/translattribute.ml @@ -361,8 +361,8 @@ let check_poll_local loc attr = () let lfunction_with_attr ~attr - { kind; params; return; body; attr=_; loc; mode; region } = - lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region + { kind; params; return; body; attr=_; loc; mode; ret_mode; region } = + lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region let add_inline_attribute expr loc attributes = match expr with diff --git a/lambda/translclass.ml b/lambda/translclass.ml index 10f430931cd..976043558c5 100644 --- a/lambda/translclass.ml +++ b/lambda/translclass.ml @@ -37,12 +37,12 @@ let layout_meth = layout_any_value let layout_tables = Lambda.Pvalue Pgenval -let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) return_layout params body = +let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) ?(ret_mode=alloc_heap) return_layout params body = if params = [] then body else match kind, body with | Curried {nlocal=0}, Lfunction {kind = Curried _ as kind; params = params'; - body = body'; attr; loc} + body = body'; attr; loc; mode = Alloc_heap; ret_mode; region} when List.length params + List.length params' <= Lambda.max_arity() -> lfunction ~kind ~params:(params @ params') ~return:return_layout @@ -50,6 +50,7 @@ let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) return_layout params bod ~attr ~loc ~mode:alloc_heap + ~ret_mode ~region | _ -> lfunction ~kind ~params ~return:return_layout @@ -57,6 +58,7 @@ let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) return_layout params bod ~attr:default_function_attribute ~loc:Loc_unknown ~mode:alloc_heap + ~ret_mode ~region let lapply ap = @@ -226,6 +228,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = ~loc:(of_location ~scopes pat.pat_loc) ~body ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true in begin match obj_init with @@ -514,6 +517,7 @@ let rec transl_class_rebind ~scopes obj_init cl vf = ~loc:(of_location ~scopes pat.pat_loc) ~body ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true in (path, path_lam, @@ -792,7 +796,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let new_ids_meths = ref [] in let no_env_update _ _ env = env in let msubst arr = function - Lfunction {kind = Curried _ as kind; region; + Lfunction {kind = Curried _ as kind; region; ret_mode; params = self :: args; return; body} -> let env = Ident.create_local "env" in let body' = @@ -804,7 +808,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = if not arr || !Clflags.debug then raise Not_found; builtin_meths [self.name] env env2 (lfunction return args body') with Not_found -> - [lfunction ~kind ~region return (self :: args) + [lfunction ~kind ~region ~ret_mode return (self :: args) (if not (Ident.Set.mem env (free_variables body')) then body' else Llet(Alias, layout_block, env, Lprim(Pfield_computed Reads_vary, @@ -875,6 +879,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~loc:Loc_unknown ~return:layout_function ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true ~params:[lparam cla layout_table] ~body:cl_init) in Llet(Strict, layout_function, class_init, cl_init, lam (free_variables cl_init)) @@ -900,6 +905,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~loc:Loc_unknown ~return:layout_function ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true ~params:[lparam cla layout_table] ~body:cl_init; lambda_unit; lenvs], @@ -960,6 +966,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~attr:default_function_attribute ~loc:Loc_unknown ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true ~body:(def_ids cla cl_init), lam) and lcache lam = @@ -985,6 +992,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~attr:default_function_attribute ~loc:Loc_unknown ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true ~return:layout_function ~params:[lparam cla layout_table] diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 157e13f2c97..79f5ba2fbfd 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -235,7 +235,7 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases [{c_lhs=pat; c_guard=None; c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; region; curry; warnings; arg_mode; - arg_sort; ret_sort; alloc_mode } } + arg_sort; ret_mode; ret_sort; alloc_mode } } as exp}] when bindings = [] || trivial_pat pat -> let cases = push_defaults exp.exp_loc bindings false arg_mode arg_sort cases partial @@ -245,7 +245,7 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases; partial; region; curry; warnings; arg_mode; - arg_sort; ret_sort; alloc_mode }}}] + arg_sort; ret_mode; ret_sort; alloc_mode }}}] | [{c_lhs=pat; c_guard=None; c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}]; exp_desc = Texp_let @@ -396,8 +396,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e = transl_let ~scopes ~return_layout rec_flag pat_expr_list (event_before ~scopes body (transl_exp ~scopes sort body)) | Texp_function { arg_label = _; param; cases; partial; region; curry; - warnings; arg_mode; arg_sort; ret_sort; alloc_mode } -> - transl_function ~in_new_scope ~scopes e alloc_mode param arg_mode arg_sort ret_sort + warnings; arg_mode; arg_sort; ret_mode; ret_sort; alloc_mode } -> + transl_function ~in_new_scope ~scopes e alloc_mode param arg_mode arg_sort ret_mode ret_sort cases partial warnings region curry | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}, Id_prim pmode, _); @@ -851,6 +851,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ~attr:default_function_attribute ~loc:(of_location ~scopes e.exp_loc) ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true ~body:(maybe_region_layout Lambda.layout_lazy_contents @@ -974,6 +975,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ~loc:(of_location ~scopes exp.exp_loc) ~attr ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true in let app = @@ -1175,7 +1177,7 @@ and transl_apply ~scopes mode = arg_mode }] in lfunction ~kind:(Curried {nlocal}) ~params - ~return:result_layout ~body ~mode ~region + ~return:result_layout ~body ~mode ~ret_mode ~region ~attr:default_stub_attribute ~loc in List.fold_right @@ -1196,18 +1198,18 @@ and transl_apply ~scopes build_apply lam [] loc position mode args and transl_curried_function - ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc repr ~region + ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc repr ~region ~return_mode ~curry partial warnings (param:Ident.t) cases = let max_arity = Lambda.max_arity () in let rec loop ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc - ~arity ~region ~curry ~arg_mode partial warnings (param:Ident.t) cases = + ~arity ~region ~return_mode ~curry ~arg_mode partial warnings (param:Ident.t) cases = match curry, cases with More_args {partial_mode}, [{c_lhs=pat; c_guard=None; c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases = cases'; - partial = partial'; region = region'; + partial = partial'; region = region'; ret_mode; curry = curry'; warnings = warnings'; arg_mode = arg_mode'; arg_sort; ret_sort }; exp_env; exp_type; exp_loc }}] @@ -1216,15 +1218,16 @@ and transl_curried_function if Parmatch.inactive ~partial pat then let partial_mode = transl_alloc_mode partial_mode in - let ((fnkind, params, return_layout, region), body) = + let ((fnkind, params, return_layout, region, return_mode), body) = let return_layout = function_return_layout exp_env exp_loc ret_sort exp_type in let arg_layout = function_arg_layout exp_env exp_loc arg_sort exp_type in + let return_mode' = transl_alloc_mode ret_mode in loop ~scopes ~arg_sort ~arg_layout ~arg_mode:arg_mode' ~return_sort:ret_sort - ~return_layout exp_loc ~arity:(arity + 1) ~region:region' + ~return_layout exp_loc ~arity:(arity + 1) ~region:region' ~return_mode:return_mode' ~curry:curry' partial' warnings' param' cases' in let fnkind = @@ -1246,7 +1249,7 @@ and transl_curried_function mode = arg_mode } :: params in - ((fnkind, params, return_layout, region), + ((fnkind, params, return_layout, region, return_mode), Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout loc None (Lvar param) [pat, body] partial) else begin @@ -1260,18 +1263,18 @@ and transl_curried_function | Partial -> () end; transl_tupled_function ~scopes ~arg_sort ~arg_layout ~arg_mode - ~return_sort:ret_sort ~return_layout ~arity ~region ~curry loc repr + ~return_sort:ret_sort ~return_layout ~arity ~region ~return_mode ~curry loc repr partial param cases end | curry, cases -> transl_tupled_function ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort - ~return_layout ~arity ~region ~curry loc repr partial param cases + ~return_layout ~arity ~region ~return_mode ~curry loc repr partial param cases in loop ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc ~arity:1 - ~region ~curry partial warnings param cases + ~region ~return_mode ~curry partial warnings param cases and transl_tupled_function - ~scopes ~arg_layout ~arg_sort ~arg_mode ~return_sort ~return_layout ~arity ~region + ~scopes ~arg_layout ~arg_sort ~arg_mode ~return_sort ~return_layout ~arity ~region ~return_mode ~curry loc repr partial (param:Ident.t) cases = let partial_mode = match curry with @@ -1315,16 +1318,16 @@ and transl_tupled_function (transl_tupled_cases ~scopes return_sort pats_expr_list) partial in let region = region || not (may_allocate_in_region body) in - ((Tupled, tparams, return_layout, region), body) + ((Tupled, tparams, return_layout, region, return_mode), body) with Matching.Cannot_flatten -> transl_function0 ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout - loc ~region ~partial_mode repr partial param cases + loc ~region ~return_mode ~partial_mode repr partial param cases end | _ -> transl_function0 ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort - ~return_layout loc ~region ~partial_mode repr partial param cases + ~return_layout loc ~region ~return_mode ~partial_mode repr partial param cases and transl_function0 - ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc ~region + ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc ~region ~return_mode ~partial_mode repr partial (param:Ident.t) cases = let body = Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout loc @@ -1332,10 +1335,9 @@ and transl_function0 in let region = region || not (may_allocate_in_region body) in let nlocal = - if not region then 1 - else match partial_mode with - | Alloc_local -> 1 - | Alloc_heap -> 0 + match return_mode, partial_mode with + | Alloc_local, _ | _, Alloc_local -> 1 + | Alloc_heap, Alloc_heap -> 0 in let arg_mode = transl_alloc_mode arg_mode in ((Curried {nlocal}, @@ -1343,11 +1345,12 @@ and transl_function0 layout = arg_layout; attributes = Lambda.default_param_attribute; mode = arg_mode}], - return_layout, region), body) + return_layout, region, return_mode), body) -and transl_function ~in_new_scope ~scopes e alloc_mode param arg_mode arg_sort return_sort +and transl_function ~in_new_scope ~scopes e alloc_mode param arg_mode arg_sort ret_mode return_sort cases partial warnings region curry = let mode = transl_alloc_mode alloc_mode in + let ret_mode = transl_alloc_mode ret_mode in let attrs = (* Collect attributes from the Pexp_newtype node for locally abstract types. Otherwise we'd ignore the attribute in, e.g.; @@ -1371,7 +1374,7 @@ and transl_function ~in_new_scope ~scopes e alloc_mode param arg_mode arg_sort r let arg_layout = function_arg_layout e.exp_env e.exp_loc arg_sort e.exp_type in - let ((kind, params, return, region), body) = + let ((kind, params, return, region, ret_mode), body) = event_function ~scopes e (function repr -> let pl = @@ -1381,13 +1384,13 @@ and transl_function ~in_new_scope ~scopes e alloc_mode param arg_mode arg_sort r function_return_layout e.exp_env e.exp_loc return_sort e.exp_type in transl_curried_function ~arg_sort ~arg_layout ~arg_mode ~return_sort - ~return_layout ~scopes e.exp_loc repr ~region ~curry partial warnings + ~return_layout ~scopes e.exp_loc repr ~region ~return_mode:ret_mode ~curry partial warnings param pl) in let attr = default_function_attribute in let loc = of_location ~scopes e.exp_loc in let body = if region then maybe_region_layout return body else body in - let lam = lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region in + let lam = lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region in Translattribute.add_function_attributes lam e.exp_loc attrs (* Like transl_exp, but used when a new scope was just introduced. *) @@ -1795,19 +1798,22 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort in let return_layout = layout_exp case_sort case.c_rhs in let curry = More_args { partial_mode = Mode.Alloc.legacy } in - let (kind, params, return, _region), body = + let return_mode = alloc_heap (* XXX fixme: use result of is_function_type *) in + let (kind, params, return, _region, ret_mode), body = event_function ~scopes case.c_rhs (function repr -> transl_curried_function ~scopes ~arg_sort:param_sort ~arg_layout ~arg_mode:Mode.Alloc.legacy ~return_sort:case_sort - ~return_layout case.c_rhs.exp_loc repr ~region:true ~curry partial + ~return_layout case.c_rhs.exp_loc repr ~region:true + ~return_mode + ~curry partial warnings param [case]) in let attr = default_function_attribute in let loc = of_location ~scopes case.c_rhs.exp_loc in let body = maybe_region_layout return body in lfunction ~kind ~params ~return ~body ~attr ~loc - ~mode:alloc_heap ~region:true + ~mode:alloc_heap ~ret_mode ~region:true in Lapply{ ap_loc = of_location ~scopes loc; diff --git a/lambda/translmod.ml b/lambda/translmod.ml index 398308b5d10..09f3af7c81c 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -162,6 +162,7 @@ and apply_coercion_result loc strict funct params args cc_res = stub = true; } ~loc ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true ~body:(apply_coercion loc Strict cc_res @@ -593,6 +594,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc = } ~loc ~mode:alloc_heap + ~ret_mode:alloc_heap ~region:true ~body diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 2c85c80a19d..2c6ea250c5a 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -1002,6 +1002,7 @@ let transl_primitive loc p env ty ~poly_mode path = ~loc ~body ~mode:alloc_heap + ~ret_mode:(to_locality p.prim_native_repr_res) ~region let lambda_primitive_needs_event_after = function diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index fe4df80ad93..efda1344a7a 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -1143,6 +1143,8 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) }) ~loc ~mode:new_clos_mode + ~ret_mode + (* CR ncourant: this is incorrect, but the mode will not be used for anything *) ~region:fundesc.fun_region ~attr:default_function_attribute) in @@ -1493,8 +1495,8 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ (List.map (function | (id, Lfunction{kind; params; return; body; attr; - loc; mode; region}) -> - Simplif.split_default_wrapper ~id ~kind ~params ~mode ~region + loc; mode; ret_mode; region}) -> + Simplif.split_default_wrapper ~id ~kind ~params ~mode ~ret_mode ~region ~body ~attr ~loc ~return | _ -> assert false ) diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index daa1683cbf5..b9a29d7104f 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -40,10 +40,10 @@ let add_default_argument_wrappers lam = match lam with | Llet (( Strict | Alias | StrictOpt), _k, id, Lfunction {kind; params; body = fbody; attr; loc; - mode; region; return }, body) -> + ret_mode; mode; region; return }, body) -> begin match Simplif.split_default_wrapper ~id ~kind ~params - ~body:fbody ~return ~attr ~loc ~mode ~region + ~body:fbody ~return ~attr ~loc ~ret_mode ~mode ~region with | [fun_id, def] -> Llet (Alias, Lambda.layout_function, fun_id, def, body) | [fun_id, def; inner_fun_id, def_inner] -> @@ -58,9 +58,9 @@ let add_default_argument_wrappers lam = (List.map (function | (id, Lambda.Lfunction {kind; params; body; attr; loc; - mode; region; return }) -> + ret_mode; mode; region; return }) -> Simplif.split_default_wrapper ~id ~kind ~params ~body - ~return ~attr ~loc ~mode ~region + ~return ~attr ~loc ~ret_mode ~mode ~region | _ -> assert false) defs) in diff --git a/testsuite/tests/backtrace/backtrace_systhreads.ml b/testsuite/tests/backtrace/backtrace_systhreads.ml index 5a31d226166..eacc719d29d 100644 --- a/testsuite/tests/backtrace/backtrace_systhreads.ml +++ b/testsuite/tests/backtrace/backtrace_systhreads.ml @@ -9,7 +9,7 @@ include systhreads let throw_exn msg = (failwith [@inlined never]) msg [@@inline never] -let thread_func delay = +let[@inline never] thread_func delay = Thread.yield (); try throw_exn (string_of_int delay) with | exn -> @@ -17,7 +17,7 @@ let thread_func delay = Gc.minor (); raise exn -let thread_backtrace (cond, mut) = +let[@inline never] thread_backtrace (cond, mut) = Thread.yield (); try throw_exn "backtrace" with | exn -> diff --git a/testsuite/tests/lib-threads/uncaught_exception_handler.ml b/testsuite/tests/lib-threads/uncaught_exception_handler.ml index 06cf8f60f0e..b2f1956b56b 100644 --- a/testsuite/tests/lib-threads/uncaught_exception_handler.ml +++ b/testsuite/tests/lib-threads/uncaught_exception_handler.ml @@ -25,9 +25,10 @@ let handler final_exn exn = flush stderr; raise final_exn -let fn () = Printexc.raise_with_backtrace - CallbackExn - (Printexc.get_raw_backtrace ()) +(* don't inline to get consistent backtraces *) +let[@inline never] fn () = + Printexc.raise_with_backtrace + CallbackExn (Printexc.get_raw_backtrace ()) let _ = let th = Thread.create fn () in diff --git a/testsuite/tests/lib-threads/uncaught_exception_handler.reference b/testsuite/tests/lib-threads/uncaught_exception_handler.reference index 17c8f09b215..74b1f914f75 100644 --- a/testsuite/tests/lib-threads/uncaught_exception_handler.reference +++ b/testsuite/tests/lib-threads/uncaught_exception_handler.reference @@ -1,15 +1,15 @@ Thread 1 killed on uncaught exception Uncaught_exception_handler.CallbackExn -Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 28, characters 12-113 +Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 30, characters 2-79 Called from Thread.create.(fun) in file "thread.ml", line 51, characters 8-14 [thread 2] caught Uncaught_exception_handler.CallbackExn -Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 28, characters 12-113 +Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 30, characters 2-79 Called from Thread.create.(fun) in file "thread.ml", line 51, characters 8-14 Thread 2 killed on uncaught exception Uncaught_exception_handler.CallbackExn -Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 28, characters 12-113 +Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 30, characters 2-79 Called from Thread.create.(fun) in file "thread.ml", line 51, characters 8-14 Thread 2 uncaught exception handler raised Uncaught_exception_handler.UncaughtHandlerExn Raised at Uncaught_exception_handler.handler in file "uncaught_exception_handler.ml", line 26, characters 2-17 Called from Thread.create.(fun) in file "thread.ml", line 60, characters 10-41 [thread 3] caught Uncaught_exception_handler.CallbackExn -Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 28, characters 12-113 +Raised at Uncaught_exception_handler.fn in file "uncaught_exception_handler.ml", line 30, characters 2-79 Called from Thread.create.(fun) in file "thread.ml", line 51, characters 8-14 diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index beddfa6b31b..ccf88bf80c9 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -379,10 +379,10 @@ let expr sub x = let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in Texp_let (rec_flag, list, sub.expr sub exp) | Texp_function { arg_label; param; cases; partial; region; curry; - warnings; arg_mode; arg_sort; ret_sort; alloc_mode } -> + warnings; arg_mode; arg_sort; ret_mode; ret_sort; alloc_mode } -> let cases = List.map (sub.case sub) cases in Texp_function { arg_label; param; cases; partial; region; curry; - warnings; arg_mode; arg_sort; ret_sort; alloc_mode } + warnings; arg_mode; arg_sort; ret_mode; ret_sort; alloc_mode } | Texp_apply (exp, list, pos, am) -> Texp_apply ( sub.expr sub exp, diff --git a/typing/typecore.ml b/typing/typecore.ml index b080ab387d1..1ebb75c7b1f 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -6514,7 +6514,7 @@ and type_function exp_desc = Texp_function { arg_label; param; cases; partial; region; curry; warnings; - arg_mode; arg_sort; alloc_mode; ret_sort }; + arg_mode; arg_sort; alloc_mode; ret_mode; ret_sort }; exp_loc = loc; exp_extra = []; exp_type = instance (newgenty (Tarrow((arg_label,arg_mode,ret_mode), @@ -7037,7 +7037,7 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg exp_desc = Texp_function { arg_label = Nolabel; param; cases; partial = Total; region = false; curry; warnings = Warnings.backup (); - arg_mode = marg; arg_sort; ret_sort; + arg_mode = marg; arg_sort; ret_mode = mret; ret_sort; alloc_mode } } in Location.prerr_warning texp.exp_loc diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 6be08e78673..3cb5570b2e0 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -121,6 +121,7 @@ and expression_desc = warnings : Warnings.state; arg_mode : Mode.Alloc.t; arg_sort : Jkind.sort; + ret_mode : Mode.Alloc.t; ret_sort : Jkind.sort; alloc_mode : Mode.Alloc.t } | Texp_apply of diff --git a/typing/typedtree.mli b/typing/typedtree.mli index e36398f6ff0..af02234871c 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -232,8 +232,13 @@ and expression_desc = warnings : Warnings.state; arg_mode : Mode.Alloc.t; arg_sort : Jkind.sort; + ret_mode : Mode.Alloc.t; + (* Mode where the function allocates, ie local for a function of + type 'a -> local_ 'b, and heap for a function of type 'a -> 'b *) ret_sort : Jkind.sort; - alloc_mode : Mode.Alloc.t} + alloc_mode : Mode.Alloc.t + (* Mode at which the closure is allocated *) + } (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function]. See {!Parsetree} for more details.