ocaml-flambda · gretay-js · Dec 2, 2022 · Nov 15, 2022
diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
@@ -18,7 +18,7 @@ jobs:
             ocamlrunparam: "v=0,V=1"
 
           - name: closure_cfg_local
-            config: --enable-middle-end=closure --enable-stack-allocation
+            config: --enable-middle-end=closure --enable-stack-allocation --enable-poll-insertion
             os: ubuntu-latest
             ocamlparam: _,ocamlcfg=1
 
@@ -28,12 +28,12 @@ jobs:
             ocamlparam: ''
 
           - name: flambda1_frame_pointers
-            config: --enable-middle-end=flambda --enable-frame-pointers
+            config: --enable-middle-end=flambda --enable-frame-pointers --enable-poll-insertion
             os: ubuntu-latest
             ocamlparam: ''
 
           - name: flambda1_cfg_local
-            config: --enable-middle-end=flambda --enable-stack-allocation
+            config: --enable-middle-end=flambda --enable-stack-allocation --enable-poll-insertion
             os: ubuntu-latest
             ocamlparam: _,ocamlcfg=1
 
@@ -45,7 +45,7 @@ jobs:
             ocamlrunparam: "v=0,V=1"
 
           - name: flambda2_frame_pointers
-            config: --enable-middle-end=flambda2 --enable-frame-pointers
+            config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-poll-insertion
             os: ubuntu-latest
             ocamlparam: ''
 

diff --git a/backend/polling.ml b/backend/polling.ml
@@ -262,6 +262,7 @@ let find_poll_alloc_or_calls instr =
   List.rev !matches
 
 let is_disabled fun_name =
+  (not Config.poll_insertion) ||
   !Flambda_backend_flags.disable_poll_insertion ||
   function_is_assumed_to_never_poll fun_name
 

@@ -19,5 +19,6 @@
    no_flat_float_array
    perf_demangled_symbols
    stack_allocation
+   poll_insertion
    ))
  )
diff --git a/driver/flambda_backend_args.ml b/driver/flambda_backend_args.ml
@@ -62,6 +62,9 @@ let mk_dcheckmach f =
 let mk_disable_poll_insertion f =
   "-disable-poll-insertion", Arg.Unit f, " Do not insert poll points"
 
+let mk_enable_poll_insertion f =
+  "-enable-poll-insertion", Arg.Unit f, " Insert poll points"
+
 let mk_long_frames f =
   "-long-frames", Arg.Unit f, " Allow stack frames longer than 2^16 bytes"
 
@@ -467,6 +470,7 @@ module type Flambda_backend_options = sig
   val dcheckmach : unit -> unit
 
   val disable_poll_insertion : unit -> unit
+  val enable_poll_insertion : unit -> unit
 
   val long_frames : unit -> unit
   val no_long_frames : unit -> unit
@@ -547,6 +551,7 @@ struct
     mk_dcheckmach F.dcheckmach;
 
     mk_disable_poll_insertion F.disable_poll_insertion;
+    mk_enable_poll_insertion F.enable_poll_insertion;
 
     mk_long_frames F.long_frames;
     mk_no_long_frames F.no_long_frames;
@@ -663,6 +668,7 @@ module Flambda_backend_options_impl = struct
   let dcheckmach = set' Flambda_backend_flags.dump_checkmach
 
   let disable_poll_insertion = set' Flambda_backend_flags.disable_poll_insertion
+  let enable_poll_insertion = clear' Flambda_backend_flags.disable_poll_insertion
 
   let long_frames =  set' Flambda_backend_flags.allow_long_frames
   let no_long_frames = clear' Flambda_backend_flags.allow_long_frames
@@ -868,7 +874,7 @@ module Extra_params = struct
     | "heap-reduction-threshold" -> set_int' Flambda_backend_flags.heap_reduction_threshold
     | "alloc-check" -> set' Flambda_backend_flags.alloc_check
     | "dump-checkmach" -> set' Flambda_backend_flags.dump_checkmach
-    | "disable-poll-insertion" -> set' Flambda_backend_flags.disable_poll_insertion
+    | "poll-insertion" -> set' Flambda_backend_flags.disable_poll_insertion
     | "long-frames" -> set' Flambda_backend_flags.allow_long_frames
     | "debug-long-frames-threshold" ->
       begin match Compenv.check_int ppf name v with

diff --git a/driver/flambda_backend_args.mli b/driver/flambda_backend_args.mli
@@ -37,6 +37,8 @@ module type Flambda_backend_options = sig
   val dcheckmach : unit -> unit
 
   val disable_poll_insertion : unit -> unit
+  val enable_poll_insertion : unit -> unit
+
   val long_frames : unit -> unit
   val no_long_frames : unit -> unit
   val long_frames_threshold : int -> unit

diff --git a/driver/flambda_backend_flags.ml b/driver/flambda_backend_flags.ml
@@ -27,9 +27,8 @@ let heap_reduction_threshold = ref default_heap_reduction_threshold (* -heap-red
 let alloc_check = ref false             (* -alloc-check *)
 let dump_checkmach = ref false          (* -dcheckmach *)
 
-(* CR-soon gyorsh: re-enable tests testsuite/tests/asmcomp/poll_*
-   when changing the default for [disable_poll_insertion] to false. *)
-let disable_poll_insertion = ref true   (* -disable-poll-insertion *)
+let disable_poll_insertion = ref (not Config.poll_insertion)
+                                        (* -disable-poll-insertion *)
 let allow_long_frames = ref true        (* -no-long-frames *)
 (* Keep the value of [max_long_frames_threshold] in sync with LONG_FRAME_MARKER
    in ocaml/runtime/roots_nat.c *)

diff --git a/ocaml/Makefile.config.in b/ocaml/Makefile.config.in
@@ -252,6 +252,7 @@ STDLIB_MANPAGES=@stdlib_manpages@
 NAKED_POINTERS=@naked_pointers@
 INTEL_JCC_BUG_CFLAGS=@intel_jcc_bug_cflags@
 STACK_ALLOCATION=@stack_allocation@
+POLL_INSERTION=@poll_insertion@
 DUNE=@dune@
 
 ### Native command to build ocamlrun.exe

diff --git a/ocaml/configure b/ocaml/configure
diff --git a/ocaml/configure.ac b/ocaml/configure.ac
@@ -173,6 +173,7 @@ AC_SUBST([naked_pointers])
 AC_SUBST([naked_pointers_checker])
 AC_SUBST([intel_jcc_bug_cflags])
 AC_SUBST([stack_allocation])
+AC_SUBST([poll_insertion])
 AC_SUBST([dune])
 
 ## Generated files
@@ -439,6 +440,10 @@ AC_ARG_ENABLE([stack-allocation],
   [AS_HELP_STRING([--enable-stack-allocation],
     [enable stack allocation of local values])])
 
+AC_ARG_ENABLE([poll-insertion],
+  [AS_HELP_STRING([--enable-poll-insertion],
+    [enable insertion of poll points])])
+
 AC_ARG_WITH([flexdll],
   [AS_HELP_STRING([--with-flexdll],
     [bootstrap FlexDLL from the given sources])],
@@ -2035,6 +2040,11 @@ AS_IF([test x"$enable_stack_allocation" = "xyes"],
    stack_allocation=true],
   [stack_allocation=false])
 
+AS_IF([test x"$enable_poll_insertion" = "xyes"],
+  [AC_DEFINE([POLL_INSERTION])
+   poll_insertion=true],
+  [poll_insertion=false])
+
 oc_cflags="$common_cflags $internal_cflags"
 oc_cppflags="$common_cppflags $internal_cppflags"
 ocamlc_cflags="$common_cflags $sharedlib_cflags \$(CFLAGS)"

diff --git a/ocaml/ocamltest/Makefile b/ocaml/ocamltest/Makefile
@@ -277,6 +277,7 @@ ocamltest_config.ml: ocamltest_config.ml.in Makefile ../Makefile.config
 	    $(call SUBST,NAKED_POINTERS) \
 	    $(call SUBST,PROBES) \
 	    $(call SUBST,STACK_ALLOCATION) \
+	    $(call SUBST,POLL_INSERTION) \
 	    $< > $@
 
 # Manual

diff --git a/ocaml/ocamltest/ocaml_actions.ml b/ocaml/ocamltest/ocaml_actions.ml
@@ -1213,6 +1213,18 @@ let no_stack_allocation = Actions.make
     "Stack allocation disabled"
     "Stack allocation enabled")
 
+let poll_insertion = Actions.make
+  "poll-insertion"
+  (Actions_helpers.pass_or_skip Ocamltest_config.poll_insertion
+    "Poll insertion enabled"
+    "Poll insertion disabled")
+
+let no_poll_insertion = Actions.make
+  "no-poll-insertion"
+  (Actions_helpers.pass_or_skip (not Ocamltest_config.poll_insertion)
+    "Stack allocation disabled"
+    "Stack allocation enabled")
+
 let ocamldoc = Ocaml_tools.ocamldoc
 
 let ocamldoc_output_file env prefix =
@@ -1410,6 +1422,8 @@ let _ =
     no_afl_instrument;
     stack_allocation;
     no_stack_allocation;
+    poll_insertion;
+    no_poll_insertion;
     setup_ocamldoc_build_env;
     run_ocamldoc;
     check_ocamldoc_output;

diff --git a/ocaml/ocamltest/ocamltest_config.ml.in b/ocaml/ocamltest/ocamltest_config.ml.in
@@ -94,3 +94,5 @@ let naked_pointers = %%NAKED_POINTERS%%
 let probes = %%PROBES%%
 
 let stack_allocation = %%STACK_ALLOCATION%%
+
+let poll_insertion = %%POLL_INSERTION%%
diff --git a/ocaml/ocamltest/ocamltest_config.mli b/ocaml/ocamltest/ocamltest_config.mli
@@ -133,3 +133,6 @@ val probes : bool
 
 val stack_allocation : bool
 (** Whether stack allocation is enabled *)
+
+val poll_insertion : bool
+(** Whether poll insertion is enabled *)
diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_both.ml b/ocaml/testsuite/tests/asmcomp/poll_attr_both.ml
@@ -1,13 +1,14 @@
 (* TEST
-  * setup-ocamlopt.byte-build-env
-  ** ocamlopt.byte
+  * poll-insertion
+  ** setup-ocamlopt.byte-build-env
+  *** ocamlopt.byte
 ocamlopt_byte_exit_status = "2"
-  *** check-ocamlopt.byte-output
+  **** check-ocamlopt.byte-output
 
-  * setup-ocamlopt.opt-build-env
-  ** ocamlopt.opt
+  ** setup-ocamlopt.opt-build-env
+  *** ocamlopt.opt
 ocamlopt_opt_exit_status = "2"
-  *** check-ocamlopt.opt-output
+  **** check-ocamlopt.opt-output
 *)
 
 let[@inline never][@local never] v x = x + 1

diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_inserted.ml b/ocaml/testsuite/tests/asmcomp/poll_attr_inserted.ml
@@ -1,13 +1,14 @@
 (* TEST
-  * setup-ocamlopt.byte-build-env
-  ** ocamlopt.byte
+  * poll-insertion
+  ** setup-ocamlopt.byte-build-env
+  *** ocamlopt.byte
 ocamlopt_byte_exit_status = "2"
-  *** check-ocamlopt.byte-output
+  **** check-ocamlopt.byte-output
 
-  * setup-ocamlopt.opt-build-env
-  ** ocamlopt.opt
+  ** setup-ocamlopt.opt-build-env
+  *** ocamlopt.opt
 ocamlopt_opt_exit_status = "2"
-  *** check-ocamlopt.opt-output
+  **** check-ocamlopt.opt-output
 *)
 
 let[@poll error] c x =

diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.ml b/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.ml
@@ -1,13 +1,14 @@
 (* TEST
-  * setup-ocamlopt.byte-build-env
-  ** ocamlopt.byte
+  * poll-insertion
+  ** setup-ocamlopt.byte-build-env
+  *** ocamlopt.byte
 ocamlopt_byte_exit_status = "2"
-  *** check-ocamlopt.byte-output
+  **** check-ocamlopt.byte-output
 
-  * setup-ocamlopt.opt-build-env
-  ** ocamlopt.opt
+  ** setup-ocamlopt.opt-build-env
+  *** ocamlopt.opt
 ocamlopt_opt_exit_status = "2"
-  *** check-ocamlopt.opt-output
+  **** check-ocamlopt.opt-output
 *)
 
 let[@poll error] rec c x l =

diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_user.ml b/ocaml/testsuite/tests/asmcomp/poll_attr_user.ml
@@ -1,13 +1,14 @@
 (* TEST
-  * setup-ocamlopt.byte-build-env
-  ** ocamlopt.byte
+  * poll-insertion
+  ** setup-ocamlopt.byte-build-env
+  *** ocamlopt.byte
 ocamlopt_byte_exit_status = "2"
-  *** check-ocamlopt.byte-output
+  **** check-ocamlopt.byte-output
 
-  * setup-ocamlopt.opt-build-env
-  ** ocamlopt.opt
+  ** setup-ocamlopt.opt-build-env
+  *** ocamlopt.opt
 ocamlopt_opt_exit_status = "2"
-  *** check-ocamlopt.opt-output
+  **** check-ocamlopt.opt-output
 *)
 
 let[@inline never][@local never] v x = x + 1

diff --git a/ocaml/testsuite/tests/asmcomp/polling_insertion.ml b/ocaml/testsuite/tests/asmcomp/polling_insertion.ml
@@ -1,8 +1,9 @@
 (* TEST
    modules = "polling.c"
    compare_programs = "false"
-   * arch64
-   ** native
+   * poll-insertion
+   ** arch64
+   *** native
 *)
 
 (* This set of tests examine poll insertion behaviour. We do this by requesting

diff --git a/ocaml/utils/Makefile b/ocaml/utils/Makefile
@@ -99,6 +99,7 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile
 	    $(call SUBST,CC_HAS_DEBUG_PREFIX_MAP) \
 	    $(call SUBST,AS_HAS_DEBUG_PREFIX_MAP) \
 	    $(call SUBST,STACK_ALLOCATION) \
+	    $(call SUBST,POLL_INSERTION) \
 	    $< > $@
 
 # Test for the substitution functions above

diff --git a/ocaml/utils/config.mli b/ocaml/utils/config.mli
@@ -273,6 +273,9 @@ val afl_instrument : bool
 val stack_allocation : bool
 (** Whether to stack allocate local values *)
 
+val poll_insertion : bool
+(** Whether to insert poll points *)
+
 (** Access to configuration values *)
 val print_config : out_channel -> unit
 

diff --git a/ocaml/utils/config.mlp b/ocaml/utils/config.mlp
@@ -94,6 +94,7 @@ let probes = %%PROBES%%
 let afl_instrument = %%AFL_INSTRUMENT%%
 
 let stack_allocation = %%STACK_ALLOCATION%%
+let poll_insertion = %%POLL_INSERTION%%
 
 (* When artifacts are incompatible with upstream OCaml, ocaml-jst uses
    magic numbers ending in 5xx. (The AST and bytecode executables remain

diff --git a/testsuite/tests/asmcomp/poll_attr_both.compilers.reference b/testsuite/tests/asmcomp/poll_attr_both.compilers.reference
@@ -1,6 +1,6 @@
 File "poll_attr_both.ml", line 1:
 Error: Function with poll-error attribute contains polling points:
-	allocation at File "poll_attr_both.ml", line 16, characters 29-37
-	function call at File "poll_attr_both.ml", line 17, characters 13-16
+	allocation at File "poll_attr_both.ml", line 17, characters 29-37
+	function call at File "poll_attr_both.ml", line 18, characters 13-16
 	(plus compiler-inserted polling point(s) in prologue and/or loop back edges)
 
diff --git a/testsuite/tests/asmcomp/poll_attr_both.ml b/testsuite/tests/asmcomp/poll_attr_both.ml
@@ -1,5 +1,5 @@
 (* TEST
-  * skip
+  * poll-insertion
   ** setup-ocamlopt.byte-build-env
   *** ocamlopt.byte
 ocamlopt_byte_exit_status = "2"