From e5555c7eae6abe822fd20bf396435b93aebe8b64 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Wed, 23 Aug 2023 11:33:35 -0400 Subject: [PATCH 1/9] Add regression test --- .../syntactic-arity/comparative_alloc.ml | 121 ++++++++++++++++++ .../comparative_alloc.reference | 10 ++ 2 files changed, 131 insertions(+) create mode 100644 testsuite/tests/syntactic-arity/comparative_alloc.ml create mode 100644 testsuite/tests/syntactic-arity/comparative_alloc.reference diff --git a/testsuite/tests/syntactic-arity/comparative_alloc.ml b/testsuite/tests/syntactic-arity/comparative_alloc.ml new file mode 100644 index 000000000000..d2f526c9e4d7 --- /dev/null +++ b/testsuite/tests/syntactic-arity/comparative_alloc.ml @@ -0,0 +1,121 @@ +(* TEST + flags = "-w +A-70"; + setup-ocamlopt.byte-build-env; + ocamlopt.byte; + run; + check-program-output; +*) + +(* Check that the runtime arity of a function (i.e., its 'fast path' for + runtime application) matches its syntactic arity (i.e., the number + of arguments appearing directly following [fun]). +*) + +type (_, _) raw_arity = + | One : (int -> 'ret, 'ret) raw_arity + | Succ : ('f, 'ret) raw_arity -> (int -> 'f, 'ret) raw_arity + +let rec numeric_arity : type f ret. (f, ret) raw_arity -> int = + fun arity -> + match arity with + | One -> 1 + | Succ arity -> numeric_arity arity + 1 + +let rec apply : type f ret. (f, ret) raw_arity -> f -> int -> ret = + fun arity f arg -> + match arity with + | One -> f arg + | Succ arity -> apply arity (f arg) arg + +type 'a arity = + | Tupled + | Curried : ('a, _) raw_arity -> 'a arity + +type packed_raw_arity = Packed_raw_arity : _ raw_arity -> packed_raw_arity +type packed_arity = Packed_arity : _ arity -> packed_arity + +let arity_description (type a) (arity : a arity) = + match arity with + | Tupled -> "tupled fun" + | Curried arity -> Printf.sprintf "%d-ary fun" (numeric_arity arity) + +(* [runtime_arity] depends on representation details of functions and + is subject to change. +*) +let runtime_arity (f : 'a -> 'b) : ('a -> 'b) arity = + let clos_info = Obj.raw_field (Obj.repr f) 1 in + let raw_arity = + Nativeint.(to_int (shift_right clos_info (Sys.word_size - 8))) + in + if raw_arity < 0 then Tupled else + let rec build_arity n = + if n = 1 then Packed_raw_arity One + else + let Packed_raw_arity pred = build_arity (n-1) in + Packed_raw_arity (Succ pred) + in + let Packed_raw_arity arity = build_arity raw_arity in + (* Obj.magic is claiming that [f]'s arity matches the arity + we've constructed here. + *) + Curried (Obj.magic arity : ('a -> 'b, _) raw_arity) + +let maybe_runtime_arity (type a) (x : a) : a arity option = + let open struct + type _ is_function = + | Not_function : _ is_function + | Is_function : (_ -> _) is_function + + let is_function (type a) (x : a) = + if Obj.tag (Obj.repr x) = Obj.closure_tag + then (Obj.magic Is_function : a is_function) + else Not_function + end + in + match is_function x with + | Is_function -> Some (runtime_arity x) + | Not_function -> None + +(* The "nested arity" of a value is either: + - the empty list, if the value isn't a function + - x :: xs if the value is a function [f], where [x] is [f]'s arity, and + [xs] is the nested arity of the result of applying [f] to a value. + + "nested arity" isn't well-defined for a function that, say, returns a 2-ary + function for some inputs and a 3-ary for others. None of the functions in + this test do that. +*) +let rec nested_arity : type a. a -> packed_arity list = + fun f -> + match maybe_runtime_arity f with + | None -> [] + | Some x -> + let rest = + match x with + | Tupled -> [] + | Curried arity -> nested_arity (apply arity f 1_234) + in + Packed_arity x :: rest + +let run ~name f = + Printf.printf "%s: %s\n" name + (nested_arity f + |> List.map (fun (Packed_arity arity) -> arity_description arity) + |> String.concat " returning ") + +let () = + print_endline "Key:"; + print_endline " : "; + print_newline (); + run (fun _ _ _ -> ()) ~name:"3 params"; + run (fun _ _ -> fun _ -> ()) ~name:"2 params then 1 param"; + run (fun _ -> fun _ _ -> ()) ~name:"1 param then 2 params"; + run (fun _ -> fun _ -> fun _ -> ()) + ~name:"1 param, then 1 param, then 1 param"; + run (fun _ -> let g _ _ = () in g) + ~name:"1 param then let-bound 2 params"; + run (fun _ _ -> let g _ = () in g) + ~name:"2 params then let-bound 1 param"; + run (fun _ -> let g _ = let h _ = () in h in g) + ~name:"1 param, then let-bound 1 param, then let-bound 1 param"; +;; diff --git a/testsuite/tests/syntactic-arity/comparative_alloc.reference b/testsuite/tests/syntactic-arity/comparative_alloc.reference new file mode 100644 index 000000000000..37644c762b80 --- /dev/null +++ b/testsuite/tests/syntactic-arity/comparative_alloc.reference @@ -0,0 +1,10 @@ +Key: + : + +3 params: 3-ary fun +2 params then 1 param: 3-ary fun +1 param then 2 params: 3-ary fun +1 param, then 1 param, then 1 param: 3-ary fun +1 param then let-bound 2 params: 3-ary fun +2 params then let-bound 1 param: 3-ary fun +1 param, then let-bound 1 param, then let-bound 1 param: 3-ary fun From 84daf9e092a12ca8d6f92378ee7e751a17f81f92 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Wed, 23 Aug 2023 14:26:54 -0400 Subject: [PATCH 2/9] Turn off arity fusion for [fun] and [function] --- lambda/lambda.ml | 10 ++++++++++ lambda/lambda.mli | 3 +++ lambda/simplif.ml | 12 ++++++++---- lambda/translclass.ml | 3 ++- lambda/translcore.ml | 13 +++++++++---- lambda/translmod.ml | 4 +++- .../syntactic-arity/comparative_alloc.reference | 12 ++++++------ 7 files changed, 41 insertions(+), 16 deletions(-) diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 8c112d6bad62..ba964cd0bee0 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -285,6 +285,7 @@ type function_attribute = { is_a_functor: bool; stub: bool; tmc_candidate: bool; + may_fuse_arity: bool; } type scoped_location = Debuginfo.Scoped_location.t @@ -384,6 +385,15 @@ let default_function_attribute = { is_a_functor = false; stub = false; tmc_candidate = false; + (* Plain functions ([fun] and [function]) set [may_fuse_arity] to [false] so + that runtime arity matches syntactic arity in more situations. + + Many things compile to functions without having a notion of syntactic arity + that survives typechecking, e.g. functors. Multi-arg functors are compiled + as nested unary functions, and rely on the arity fusion in simplif to make + them multi-argument. So, we keep arity fusion turned on by default for now. + *) + may_fuse_arity = true; } let default_stub_attribute = diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 48a57b8d7df4..4186132fd40a 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -272,6 +272,9 @@ type function_attribute = { is_a_functor: bool; stub: bool; tmc_candidate: bool; + (* [may_fuse_arity] is true if [simplif.ml] is permitted to fuse arity, i.e., + to perform the rewrite [fun x -> fun y -> e] to [fun x y -> e] *) + may_fuse_arity: bool; } type scoped_location = Debuginfo.Scoped_location.t diff --git a/lambda/simplif.ml b/lambda/simplif.ml index 479b46d6bc73..8d01fcc29120 100644 --- a/lambda/simplif.ml +++ b/lambda/simplif.ml @@ -516,19 +516,23 @@ let simplify_lets lam = end | _ -> no_opt () end - | Lfunction{kind; params; return=return1; body = l; attr; loc} -> + | Lfunction{kind; params; return=return1; body = l; attr=attr1; loc} + -> begin match simplif l with - Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc} + Lfunction{kind=Curried; params=params'; return=return2; body; + attr=attr2; loc} when kind = Curried && optimize && + attr1.may_fuse_arity && attr2.may_fuse_arity && List.length params + List.length params' <= Lambda.max_arity() -> (* 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 parameters is the type returned after applying [params']. *) let return = return2 in - lfunction ~kind ~params:(params @ params') ~return ~body ~attr ~loc + lfunction ~kind ~params:(params @ params') ~return ~body ~attr:attr2 + ~loc | body -> - lfunction ~kind ~params ~return:return1 ~body ~attr ~loc + lfunction ~kind ~params ~return:return1 ~body ~attr:attr1 ~loc end | Llet(_str, _k, v, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); diff --git a/lambda/translclass.ml b/lambda/translclass.ml index 8db67e101b48..129157377060 100644 --- a/lambda/translclass.ml +++ b/lambda/translclass.ml @@ -31,7 +31,8 @@ let lfunction params body = if params = [] then body else match body with | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} - when List.length params + List.length params' <= Lambda.max_arity() -> + when attr.may_fuse_arity && + List.length params + List.length params' <= Lambda.max_arity() -> lfunction ~kind:Curried ~params:(params @ params') ~return:Pgenval ~body:body' diff --git a/lambda/translcore.ml b/lambda/translcore.ml index e08e4a5c2ec7..b9f10ab4a990 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -120,6 +120,11 @@ let assert_failed loc ~scopes exp = Const_base(Const_int line); Const_base(Const_int char)]))], loc))], loc) +(* In cases where we're careful to preserve syntactic arity, we disable + the arity fusion attempted by simplif.ml *) +let function_attribute_disallowing_arity_fusion = + { default_function_attribute with may_fuse_arity = false } + let rec cut n l = if n = 0 then ([],l) else match l with [] -> failwith "Translcore.cut" @@ -524,7 +529,7 @@ and transl_exp0 ~in_new_scope ~scopes e = let fn = lfunction ~kind:Curried ~params:[Ident.create_local "param", Pgenval] ~return:Pgenval - ~attr:default_function_attribute + ~attr:function_attribute_disallowing_arity_fusion ~loc:(of_location ~scopes e.exp_loc) ~body:(transl_exp ~scopes e) in Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], @@ -831,7 +836,7 @@ and transl_curried_function ~scopes loc return repr params body = let body, return = List.fold_right (fun chunk (body, return) -> - let attr = default_function_attribute in + let attr = function_attribute_disallowing_arity_fusion in let loc = of_location ~scopes loc in let body = lfunction ~kind:Curried ~params:chunk ~return ~body ~attr ~loc @@ -852,7 +857,7 @@ and transl_function ~scopes e params body = let params, body = fuse_method_arity params body in transl_function_without_attributes ~scopes e.exp_loc repr params body) in - let attr = default_function_attribute in + let attr = function_attribute_disallowing_arity_fusion in let loc = of_location ~scopes e.exp_loc in let lam = lfunction ~kind ~params ~return ~body ~attr ~loc in let attrs = @@ -1175,7 +1180,7 @@ and transl_letop ~scopes loc env let_ ands param case partial = { cases = [case]; param; partial; loc = ghost_loc; exp_extra = None; attributes = []; })) in - let attr = default_function_attribute in + let attr = function_attribute_disallowing_arity_fusion in let loc = of_location ~scopes case.c_rhs.exp_loc in lfunction ~kind ~params ~return ~body ~attr ~loc in diff --git a/lambda/translmod.ml b/lambda/translmod.ml index 83e8b8cdd6e6..8e0b9ab287d3 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -121,7 +121,8 @@ and apply_coercion_result loc strict funct params args cc_res = ~return:Pgenval ~attr:{ default_function_attribute with is_a_functor = true; - stub = true; } + stub = true; + may_fuse_arity = true; } ~loc ~body:(apply_coercion loc Strict cc_res @@ -500,6 +501,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc = is_a_functor = true; stub = false; tmc_candidate = false; + may_fuse_arity = true; } ~loc ~body diff --git a/testsuite/tests/syntactic-arity/comparative_alloc.reference b/testsuite/tests/syntactic-arity/comparative_alloc.reference index 37644c762b80..9f1e7c56c3e8 100644 --- a/testsuite/tests/syntactic-arity/comparative_alloc.reference +++ b/testsuite/tests/syntactic-arity/comparative_alloc.reference @@ -2,9 +2,9 @@ Key: : 3 params: 3-ary fun -2 params then 1 param: 3-ary fun -1 param then 2 params: 3-ary fun -1 param, then 1 param, then 1 param: 3-ary fun -1 param then let-bound 2 params: 3-ary fun -2 params then let-bound 1 param: 3-ary fun -1 param, then let-bound 1 param, then let-bound 1 param: 3-ary fun +2 params then 1 param: 2-ary fun returning 1-ary fun +1 param then 2 params: 1-ary fun returning 2-ary fun +1 param, then 1 param, then 1 param: 1-ary fun returning 1-ary fun returning 1-ary fun +1 param then let-bound 2 params: 1-ary fun returning 2-ary fun +2 params then let-bound 1 param: 2-ary fun returning 1-ary fun +1 param, then let-bound 1 param, then let-bound 1 param: 1-ary fun returning 1-ary fun returning 1-ary fun From ad637612ac386b10967ba8f9129ec9415e133778 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Wed, 23 Aug 2023 16:16:25 -0400 Subject: [PATCH 3/9] Add Changes --- Changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Changes b/Changes index 381da59ee270..5a24f8773d6c 100644 --- a/Changes +++ b/Changes @@ -295,7 +295,7 @@ Working version in Typecore in favor of local mutable state. (Nick Roberts, review by Takafumi Saikawa) -- #12236, #12386, #12391: Use syntax as the sole determiner of function arity +- #12236, #12386, #12391, #12496: Use syntax as the sole determiner of fun arity This changes function arity to be based solely on the source program's parsetree. Previously, the heuristic for arity had more subtle heuristics that involved type information about patterns. Function arity is important From 7602c4f624a0ac08da439650fd69d0da3a237e8c Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Mon, 16 Oct 2023 17:28:06 +0100 Subject: [PATCH 4/9] Update lambda/lambda.mli Co-authored-by: Richard Eisenberg --- lambda/lambda.mli | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 4186132fd40a..ce143291d0f0 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -272,8 +272,10 @@ type function_attribute = { is_a_functor: bool; stub: bool; tmc_candidate: bool; - (* [may_fuse_arity] is true if [simplif.ml] is permitted to fuse arity, i.e., - to perform the rewrite [fun x -> fun y -> e] to [fun x y -> e] *) + (* [simplif.ml] (in the `simplif` function within `simplify_lets`) attempts to fuse + nested functions, rewriting e.g. [fun x -> fun y -> e] to [fun x y -> e]. This + fusion is allowed only when the [may_fuse_arity] field on *both* functions + involved is [true]. *) may_fuse_arity: bool; } From 4cdb26344d30bec8562ae90812c0e15724f6dfbe Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Mon, 16 Oct 2023 17:37:30 +0100 Subject: [PATCH 5/9] Add comment explaining lazy block --- lambda/translcore.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lambda/translcore.ml b/lambda/translcore.ml index b9f10ab4a990..c5f91ccafe81 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -529,6 +529,10 @@ and transl_exp0 ~in_new_scope ~scopes e = let fn = lfunction ~kind:Curried ~params:[Ident.create_local "param", Pgenval] ~return:Pgenval + (* The translation of [e] may be a function, in + which case disallowing arity fusion gives a very + small performance improvement. + *) ~attr:function_attribute_disallowing_arity_fusion ~loc:(of_location ~scopes e.exp_loc) ~body:(transl_exp ~scopes e) in From 90c46ff4c6c422ec1ce3cf394e6e64aa8ebfec49 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Mon, 16 Oct 2023 17:38:45 +0100 Subject: [PATCH 6/9] fix long lines committed through GitHub web UI --- lambda/lambda.mli | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lambda/lambda.mli b/lambda/lambda.mli index ce143291d0f0..4936e8816ea4 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -272,10 +272,10 @@ type function_attribute = { is_a_functor: bool; stub: bool; tmc_candidate: bool; - (* [simplif.ml] (in the `simplif` function within `simplify_lets`) attempts to fuse - nested functions, rewriting e.g. [fun x -> fun y -> e] to [fun x y -> e]. This - fusion is allowed only when the [may_fuse_arity] field on *both* functions - involved is [true]. *) + (* [simplif.ml] (in the `simplif` function within `simplify_lets`) attempts to + fuse nested functions, rewriting e.g. [fun x -> fun y -> e] to + [fun x y -> e]. This fusion is allowed only when the [may_fuse_arity] field + on *both* functions involved is [true]. *) may_fuse_arity: bool; } From adba3715cbabbb866b09d98abc9e38604192a518 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Tue, 17 Oct 2023 09:39:11 +0100 Subject: [PATCH 7/9] Fix up test according to review --- .../tests/syntactic-arity/comparative_alloc.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/testsuite/tests/syntactic-arity/comparative_alloc.ml b/testsuite/tests/syntactic-arity/comparative_alloc.ml index d2f526c9e4d7..5f611787fd1a 100644 --- a/testsuite/tests/syntactic-arity/comparative_alloc.ml +++ b/testsuite/tests/syntactic-arity/comparative_alloc.ml @@ -11,6 +11,15 @@ of arguments appearing directly following [fun]). *) +(* This function will need to change if the runtime representation of closures + changes. Currently, the arity is the first 8 bits of the second field of + a closure. +*) +let extract_arity_from_closure (closure : Obj.t) : int = + assert (Obj.closure_tag = Obj.tag closure); + let clos_info = Obj.raw_field (Obj.repr closure) 1 in + Nativeint.(to_int (shift_right clos_info (Sys.word_size - 8))) + type (_, _) raw_arity = | One : (int -> 'ret, 'ret) raw_arity | Succ : ('f, 'ret) raw_arity -> (int -> 'f, 'ret) raw_arity @@ -43,10 +52,7 @@ let arity_description (type a) (arity : a arity) = is subject to change. *) let runtime_arity (f : 'a -> 'b) : ('a -> 'b) arity = - let clos_info = Obj.raw_field (Obj.repr f) 1 in - let raw_arity = - Nativeint.(to_int (shift_right clos_info (Sys.word_size - 8))) - in + let raw_arity = extract_arity_from_closure (Obj.repr f) in if raw_arity < 0 then Tupled else let rec build_arity n = if n = 1 then Packed_raw_arity One From 17db5ecfc238a5daf625b1cc482998e6c0bde5ed Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Tue, 17 Oct 2023 09:40:21 +0100 Subject: [PATCH 8/9] Rename no-longer-alloc-related test --- .../{comparative_alloc.ml => measure_runtime_arity.ml} | 0 ...omparative_alloc.reference => measure_runtime_arity.reference} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename testsuite/tests/syntactic-arity/{comparative_alloc.ml => measure_runtime_arity.ml} (100%) rename testsuite/tests/syntactic-arity/{comparative_alloc.reference => measure_runtime_arity.reference} (100%) diff --git a/testsuite/tests/syntactic-arity/comparative_alloc.ml b/testsuite/tests/syntactic-arity/measure_runtime_arity.ml similarity index 100% rename from testsuite/tests/syntactic-arity/comparative_alloc.ml rename to testsuite/tests/syntactic-arity/measure_runtime_arity.ml diff --git a/testsuite/tests/syntactic-arity/comparative_alloc.reference b/testsuite/tests/syntactic-arity/measure_runtime_arity.reference similarity index 100% rename from testsuite/tests/syntactic-arity/comparative_alloc.reference rename to testsuite/tests/syntactic-arity/measure_runtime_arity.reference From f6cd6955a11ce026b6077d152021d3c5e0ef71b9 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Tue, 17 Oct 2023 14:28:41 +0100 Subject: [PATCH 9/9] Fix incorrect comment in tests --- testsuite/tests/syntactic-arity/measure_runtime_arity.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/testsuite/tests/syntactic-arity/measure_runtime_arity.ml b/testsuite/tests/syntactic-arity/measure_runtime_arity.ml index 5f611787fd1a..a9203c7213bc 100644 --- a/testsuite/tests/syntactic-arity/measure_runtime_arity.ml +++ b/testsuite/tests/syntactic-arity/measure_runtime_arity.ml @@ -85,7 +85,8 @@ let maybe_runtime_arity (type a) (x : a) : a arity option = (* The "nested arity" of a value is either: - the empty list, if the value isn't a function - x :: xs if the value is a function [f], where [x] is [f]'s arity, and - [xs] is the nested arity of the result of applying [f] to a value. + [xs] is the nested arity of the result of applying [f] to [x] many + values. "nested arity" isn't well-defined for a function that, say, returns a 2-ary function for some inputs and a 3-ary for others. None of the functions in