Disable function sorting (oxcaml#2287)

Author: gretay-js

driver/flambda_backend_args.ml

@@ -114,6 +114,13 @@ let mk_checkmach_details_cutoff f =
      | No_details -> 0
      | At_most n -> n)
 
+let mk_function_layout f =
+  let layouts = Flambda_backend_flags.Function_layout.(List.map to_string all) in
+  let default = Flambda_backend_flags.Function_layout.(to_string default) in
+  "-function-layout", Arg.Symbol (layouts, f),
+  (Printf.sprintf " Order of functions in the generated assembly (default: %s)"
+     default)
+
 let mk_disable_poll_insertion f =
   "-disable-poll-insertion", Arg.Unit f, " Do not insert poll points"
 
@@ -629,6 +636,7 @@ module type Flambda_backend_options = sig
   val dcheckmach : unit -> unit
   val checkmach_details_cutoff : int -> unit
 
+  val function_layout : string -> unit
   val disable_poll_insertion : unit -> unit
   val enable_poll_insertion : unit -> unit
 
@@ -741,6 +749,7 @@ struct
     mk_dcheckmach F.dcheckmach;
     mk_checkmach_details_cutoff F.checkmach_details_cutoff;
 
+    mk_function_layout F.function_layout;
     mk_disable_poll_insertion F.disable_poll_insertion;
     mk_enable_poll_insertion F.enable_poll_insertion;
 
@@ -907,6 +916,12 @@ module Flambda_backend_options_impl = struct
     in
     Flambda_backend_flags.checkmach_details_cutoff := c
 
+  let function_layout s =
+    match Flambda_backend_flags.Function_layout.of_string s with
+    | None -> () (* this should not occur as we use Arg.Symbol *)
+    | Some layout ->
+      Flambda_backend_flags.function_layout := layout
+
   let disable_poll_insertion = set' Flambda_backend_flags.disable_poll_insertion
   let enable_poll_insertion = clear' Flambda_backend_flags.disable_poll_insertion
 
@@ -1179,6 +1194,13 @@ module Extra_params = struct
       | None -> ()
       end;
       true
+    | "function-layout" ->
+      (match Flambda_backend_flags.Function_layout.of_string v with
+       | Some layout -> Flambda_backend_flags.function_layout := layout; true
+       | None ->
+         raise
+           (Arg.Bad
+              (Printf.sprintf "Unexpected value %s for %s" v name)))
     | "poll-insertion" -> set' Flambda_backend_flags.disable_poll_insertion
     | "symbol-visibility-protected" -> set' Flambda_backend_flags.disable_poll_insertion
     | "long-frames" -> set' Flambda_backend_flags.allow_long_frames

driver/flambda_backend_args.mli

@@ -51,6 +51,7 @@ module type Flambda_backend_options = sig
   val dcheckmach : unit -> unit
   val checkmach_details_cutoff : int -> unit
 
+  val function_layout : string -> unit
   val disable_poll_insertion : unit -> unit
   val enable_poll_insertion : unit -> unit
 

driver/flambda_backend_flags.ml

@@ -42,6 +42,27 @@ type checkmach_details_cutoff =
 let default_checkmach_details_cutoff = At_most 20
 let checkmach_details_cutoff = ref default_checkmach_details_cutoff
                                        (* -checkmach-details-cutoff n *)
+module Function_layout = struct
+  type t =
+    | Topological
+    | Source
+
+  let to_string = function
+    | Topological -> "topological"
+    | Source -> "source"
+
+  let default = Topological
+
+  let all = [Topological; Source]
+
+  let of_string v =
+    let f t =
+      if String.equal (to_string t) v then Some t else None
+    in
+    List.find_map f all
+end
+
+let function_layout = ref Function_layout.default   (* -function-layout *)
 
 let disable_poll_insertion = ref (not Config.poll_insertion)
                                         (* -disable-poll-insertion *)

driver/flambda_backend_flags.mli

@@ -46,6 +46,20 @@ type checkmach_details_cutoff =
 val checkmach_details_cutoff : checkmach_details_cutoff ref
 val default_checkmach_details_cutoff : checkmach_details_cutoff
 
+module Function_layout : sig
+  type t =
+    | Topological
+    | Source
+
+  val to_string : t -> string
+  val of_string : string -> t option
+  val default :t
+
+  val all : t list
+end
+
+
+val function_layout : Function_layout.t ref
 val disable_poll_insertion : bool ref
 val allow_long_frames : bool ref
 val max_long_frames_threshold : int

middle_end/flambda2/to_cmm/to_cmm_result.ml

@@ -164,12 +164,15 @@ let to_cmm r =
   let r = define_module_symbol_if_missing r in
   (* Make sure we do not forget any current data *)
   let r = archive_data r in
-  (* Sort functions according to debuginfo, to get a stable ordering *)
   let sorted_functions =
-    List.sort
-      (fun (f1 : Cmm.fundecl) (f2 : Cmm.fundecl) ->
-        Debuginfo.compare f1.fun_dbg f2.fun_dbg)
-      r.functions
+    match !Flambda_backend_flags.function_layout with
+    | Topological -> List.rev r.functions
+    | Source ->
+      (* Sort functions according to debuginfo, to get a stable ordering *)
+      List.sort
+        (fun (f1 : Cmm.fundecl) (f2 : Cmm.fundecl) ->
+          Debuginfo.compare f1.fun_dbg f2.fun_dbg)
+        r.functions
   in
   let function_phrases = List.map (fun f -> C.cfunction f) sorted_functions in
   (* Translate roots to Cmm symbols *)

tests/backend/checkmach/dune.inc

@@ -163,7 +163,7 @@
  (action
    (with-outputs-to fail8.output.corrected
     (pipe-outputs
-    (with-accepted-exit-codes 2
+    (with-accepted-exit-codes 0
      (run %{bin:ocamlopt.opt} %{ml} -g -color never -error-style short -c
           -zero-alloc-check default -checkmach-details-cutoff 0 -O3))
     (run "./filter.sh")
@@ -749,3 +749,9 @@
  (enabled_if (= %{context_name} "main"))
  (deps fail24.output fail24.output.corrected)
  (action (diff fail24.output fail24.output.corrected)))
+
+(rule
+ (alias   runtest)
+ (enabled_if (= %{context_name} "main"))
+ (deps test_raise_message.ml)
+ (action (run %{bin:ocamlopt.opt} %{deps} -g -c -zero-alloc-check default -dcse -dcheckmach -dump-into-file -O3 -warn-error +a)))

tests/backend/checkmach/fail8.ml

@@ -1,4 +1,4 @@
-(* fails because forward dependency on g is treated conservatively *)
+(* forward dependency on g *)
 exception E
 let[@zero_alloc] rec f x b =
   if b then (g x; raise E)

tests/backend/checkmach/fail8.output

@@ -1,2 +0,0 @@
-File "fail8.ml", line 3, characters 5-15:
-Error: Annotation check for zero_alloc failed on function Fail8.f (camlFail8.f_HIDE_STAMP)

tests/backend/checkmach/gen/gen_dune.ml

@@ -78,7 +78,7 @@ let () =
   print_test_expected_output ~cutoff:0 ~extra_dep:None ~exit_code:2 "fail5";
   print_test_expected_output ~cutoff:0 ~extra_dep:None ~exit_code:2 "fail6";
   print_test_expected_output ~cutoff:0 ~extra_dep:None ~exit_code:2 "fail7";
-  print_test_expected_output ~cutoff:0 ~extra_dep:None ~exit_code:2 "fail8";
+  print_test_expected_output ~cutoff:0 ~extra_dep:None ~exit_code:0 "fail8";
   print_test_expected_output ~cutoff:0 ~extra_dep:None ~exit_code:2 "fail9";
   print_test_expected_output ~cutoff:0 ~extra_dep:None ~exit_code:2 "fail10";
   print_test_expected_output ~cutoff:default_cutoff  ~extra_dep:None ~exit_code:2 "fail12";
@@ -123,4 +123,5 @@ let () =
   print_test_expected_output ~cutoff:default_cutoff ~extra_dep:None ~exit_code:2 "test_attr_check_opt";
   print_test_expected_output ~cutoff:default_cutoff ~extra_dep:None ~exit_code:0 "test_attr_check_none";
   print_test_expected_output ~cutoff:default_cutoff ~extra_dep:None ~exit_code:2 "fail24";
+  print_test "test_raise_message.ml";
   ()

tests/backend/checkmach/test_raise_message.ml

@@ -0,0 +1,47 @@
+module Sexp = struct
+  type t =
+    | Atom of string
+    | List of t list
+  let of_int n = Atom (string_of_int n)
+end
+
+exception Exn of Sexp.t
+
+let raise_s sexp = raise (Exn sexp)
+[@@ocaml.inline never][@@ocaml.local never][@@ocaml.specialise never]
+
+(* Pattern before ppx looks like this: *)
+(* let[@zero_alloc] raise_invalid_index ~unknown_index ~name =
+ *   raise_s
+ *     [%message
+ *       "Unknown" (unknown_index : int) (name : string)]
+ * ;; *)
+
+let raise_invalid_index_FAIL ~unknown_index ~name =
+  raise_s
+    (let ppx_sexp_message () =
+       Sexp.List
+         [Sexp.Atom "Unknown";
+          Sexp.List
+            [Sexp.Atom "unknown_index"; Sexp.of_int unknown_index];
+          Sexp.List
+            [Sexp.Atom "name"; Sexp.Atom name]]
+     [@@ocaml.inline never][@@ocaml.local never][@@ocaml.specialise never]
+     in
+     ((ppx_sexp_message ())[@nontail ]))
+[@@ocaml.inline never][@@ocaml.local never][@@ocaml.specialise never][@@zero_alloc ]
+
+
+
+let ppx_sexp_message ~unknown_index ~name =
+  Sexp.List
+    [Sexp.Atom "Unknown";
+     Sexp.List
+       [Sexp.Atom "unknown_index"; Sexp.of_int unknown_index];
+     Sexp.List
+       [Sexp.Atom "name"; Sexp.Atom name]]
+[@@ocaml.inline never][@@ocaml.local never][@@ocaml.specialise never]
+
+let raise_invalid_index ~unknown_index ~name =
+  raise_s ((ppx_sexp_message ~unknown_index ~name)[@nontail ])
+[@@ocaml.inline never][@@ocaml.local never][@@ocaml.specialise never][@@zero_alloc ]