flambda-backend: Extensions universes (#2393)

Implement extension universes and add the `-extension-universe` flag. Also change old uses of `-disable-all-extensions` and `-only-erasable-extensions` to the new flag.

---------

Co-authored-by: Diana Kalinichenko <[email protected]>

Author: dkalinichenko-js

driver/compenv.ml

@@ -504,7 +504,8 @@ let read_one_param ppf position name v =
 
   | "extension" -> Language_extension.enable_of_string_exn v
   | "disable-all-extensions" ->
-    if check_bool ppf name v then Language_extension.disallow_extensions ()
+    if check_bool ppf name v then
+      Language_extension.set_universe_and_enable_all No_extensions
 
   | _ ->
     if !warnings_for_discarded_params &&

driver/main_args.ml

@@ -660,7 +660,8 @@ let mk_no_extension f =
 
 let mk_disable_all_extensions f =
   "-disable-all-extensions", Arg.Unit f,
-  "  Disable all extensions, wherever they have been specified; this\n\
+  "  Legacy, use [-extension-universe no_extensions].\n\
+  \    Disable all extensions, wherever they have been specified; this\n\
   \    flag overrides prior uses of the -extension flag, disables any\n\
   \    extensions that are enabled by default, and causes future uses of\n\
   \    the -extension flag to raise an error."
@@ -675,14 +676,24 @@ let mk_only_erasable_extensions f =
     String.concat ", "
   in
 "-only-erasable-extensions", Arg.Unit f,
-  "  Disable all extensions that cannot be \"erased\" to attributes,\n\
+  " Legacy, use [-extension-universe upstream_compatible].\n\
+  \    Disable all extensions that cannot be \"erased\" to attributes,\n\
   \    wherever they have been specified; this flag overrides prior\n\
   \    contradictory uses of the -extension flag, raises an error on\n\
   \    future such uses, and disables any such extensions that are\n\
   \    enabled by default.\n\
   \    (Erasable extensions: " ^ erasable_extensions ^ ")"
 ;;
 
+let mk_extension_universe f =
+  let available_extension_universes =
+    Language_extension.Universe.(List.map to_string all)
+in
+"-extension-universe", Arg.Symbol (available_extension_universes, f),
+  " Set the extension universe and enable all extensions in it. Each universe\n\
+  \    allows a set of extensions, and every successive universe includes \n\
+  \    the previous one."
+
 let mk_dump_dir f =
   "-dump-dir", Arg.String f,
   "<dir> dump output like -dlambda into <dir>/<target>.dump"
@@ -868,6 +879,7 @@ module type Common_options = sig
   val _only_erasable_extensions : unit -> unit
   val _extension : string -> unit
   val _no_extension : string -> unit
+  val _extension_universe : string -> unit
   val _noassert : unit -> unit
   val _nolabels : unit -> unit
   val _nostdlib : unit -> unit
@@ -1142,6 +1154,7 @@ struct
     mk_dtypes F._annot;
     mk_extension F._extension;
     mk_no_extension F._no_extension;
+    mk_extension_universe F._extension_universe;
     mk_for_pack_byt F._for_pack;
     mk_g_byt F._g;
     mk_no_g F._no_g;
@@ -1262,6 +1275,7 @@ struct
     mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
     mk_no_extension F._no_extension;
+    mk_extension_universe F._extension_universe;
     mk_noassert F._noassert;
     mk_noinit F._noinit;
     mk_nolabels F._nolabels;
@@ -1351,6 +1365,7 @@ struct
     mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
     mk_no_extension F._no_extension;
+    mk_extension_universe F._extension_universe;
     mk_for_pack_opt F._for_pack;
     mk_g_opt F._g;
     mk_no_g F._no_g;
@@ -1530,6 +1545,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
     mk_no_extension F._no_extension;
+    mk_extension_universe F._extension_universe;
     mk_no_float_const_prop F._no_float_const_prop;
     mk_noassert F._noassert;
     mk_noinit F._noinit;
@@ -1634,6 +1650,7 @@ struct
     mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
     mk_no_extension F._no_extension;
+    mk_extension_universe F._extension_universe;
     mk_noassert F._noassert;
     mk_nolabels F._nolabels;
     mk_nostdlib F._nostdlib;
@@ -1734,11 +1751,16 @@ module Default = struct
     let _no_strict_sequence = clear strict_sequence
     let _no_unboxed_types = clear unboxed_types
     let _no_verbose_types = clear verbose_types
-    let _disable_all_extensions = Language_extension.disallow_extensions
+    let _disable_all_extensions =
+      Language_extension.(fun () ->
+        set_universe_and_enable_all No_extensions)
     let _only_erasable_extensions =
-      Language_extension.restrict_to_erasable_extensions
+      Language_extension.(fun () ->
+        set_universe_and_enable_all Upstream_compatible)
     let _extension s = Language_extension.(enable_of_string_exn s)
     let _no_extension s = Language_extension.(disable_of_string_exn s)
+    let _extension_universe s =
+      Language_extension.(set_universe_and_enable_all_of_string_exn s)
     let _noassert = set noassert
     let _nolabels = set classic
     let _nostdlib = set no_std_include

driver/main_args.mli

@@ -31,6 +31,7 @@ module type Common_options = sig
   val _only_erasable_extensions : unit -> unit
   val _extension : string -> unit
   val _no_extension : string -> unit
+  val _extension_universe : string -> unit
   val _noassert : unit -> unit
   val _nolabels : unit -> unit
   val _nostdlib : unit -> unit

driver/makedepend.ml

@@ -665,7 +665,8 @@ let run_main argv =
     let program = Filename.basename Sys.argv.(0) in
     Compenv.parse_arguments (ref argv)
       (add_dep_arg (fun f -> Src (f, None))) program;
-    Language_extension.enable_maximal ();
+    Language_extension.set_universe_and_enable_all
+      Language_extension.Universe.maximal;
     process_dep_args (List.rev !dep_args_rev);
     Compenv.readenv ppf Before_link;
     if !sort_files then sort_files_by_dependencies !files

manual/src/cmds/unified-options.etex

@@ -896,18 +896,20 @@ either with the same or a different language extension; is idempotent.
 Disable the specified \var{language-extension}.  Can be specified more than once,
 either with the same or a different language extension; is idempotent.
 
-\item[(JST) "-only-erasable-extensions"]
-Restricts the "-extension" option to work only with so-called ``erasable''
-extensions: ones that can be rewritten into attributes while still preserving
-the program's runtime input/output behavior.  Turns off currently-enabled
-non-erasable extensions when specified.  After this flag, specifying a
-non-erasable extension (even to disable it) will fail with an error.  This flag
-cannot be reversed, but it can be strengthened (by "-disable-all-extensions").
-
-\item[(JST) "-disable-all-extensions"]
-Disallow all language extensions moving forward, and turn off currently-enabled
-ones.  This makes "-extension" raise errors moving forwards.  This flag cannot
-be reversed.
+\item[(JST) "-extension-universe" \var{universe}]
+Set the extension universe and enable all extensions in it. Each universe
+allows a set of extensions, and every successive universe includes
+the previous one. Following universes exist:
+
+\begin{options}
+\item[no_extensions] No extensions.
+\item[upstream_compatible] Extensions compatible with upstream OCaml,
+or erasable extensions.
+\item[stable] All stable extensions.
+\item[beta] All beta extensions.
+\item[alpha] All alpha extensions.
+\end{options}
+
 
 \end{options}
 %

ocamldoc/odoc.ml

@@ -18,7 +18,8 @@
 
 module M = Odoc_messages
 
-let () = Language_extension.enable_maximal ()
+let () = Language_extension.set_universe_and_enable_all
+  Language_extension.Universe.maximal
 
 (* we check if we must load a module given on the command line *)
 let arg_list = Array.to_list Sys.argv

testsuite/tests/ast-invariants/test.ml

@@ -85,5 +85,6 @@ let rec walk dir =
     (Sys.readdir dir)
 
 let () =
-  Language_extension.enable_maximal ();
+  Language_extension.set_universe_and_enable_all
+    Language_extension.Universe.maximal;
   walk root

testsuite/tests/language-extensions/language_extensions.ml

@@ -50,11 +50,11 @@ let should_fail name f =
     | exception Arg.Bad msg -> "Failed as expected: " ^ msg)
 ;;
 
-let try_disallowing_extensions name =
+let try_setting_universe univ name =
   should_succeed
     name
-    "disallowing all extensions"
-    Language_extension.disallow_extensions
+    ("setting universe " ^ Language_extension.Universe.to_string univ)
+    (fun () -> Language_extension.set_universe_and_enable_all univ)
 ;;
 
 type goal = Fail | Succeed
@@ -63,14 +63,15 @@ let with_goal goal ~name ~what test = match goal with
   | Fail    -> should_fail    name      test
   | Succeed -> should_succeed name what test
 
-let when_disallowed goal f_str f =
+let when_universe univ goal f_str f =
   let can_or_can't = match goal with
     | Fail    -> "can't"
     | Succeed -> "can"
   in
   let f_code = "[" ^ f_str ^ "]" in
   with_goal goal
-    ~name:(can_or_can't ^ " call " ^ f_code ^ " when extensions are disallowed")
+    ~name:(can_or_can't ^ " call " ^ f_code ^ " when in universe "
+      ^ Language_extension.Universe.to_string univ)
     ~what:("redundantly calling " ^ f_code)
     (fun () -> f extension)
 ;;
@@ -174,38 +175,38 @@ report ~name:"Enable two layouts, in reverse order"
          then "Succeeded"
          else "Failed");;
 
-(* Test disallowing extensions *)
+(* Test [No_extension] universe. *)
 
-try_disallowing_extensions
-  "can disallow extensions while extensions are enabled";
+try_setting_universe No_extensions
+  "can set [No_extensions] while extensions are enabled";
 
-try_disallowing_extensions
-  "can disallow extensions while extensions are already disallowed";
+try_setting_universe No_extensions
+  "setting [No_extensions] is idempotent";
 
 (* Test that disallowing extensions prevents other functions from working *)
 
-when_disallowed Fail "set ~enabled:true"
+when_universe No_extensions Fail "set ~enabled:true"
   (Language_extension.set ~enabled:true);
 
-when_disallowed Succeed "set ~enabled:false"
+when_universe No_extensions Succeed "set ~enabled:false"
   (Language_extension.set ~enabled:false);
 
-when_disallowed Fail "enable"
+when_universe No_extensions Fail "enable"
   (fun x -> Language_extension.enable x ());
 
-when_disallowed Succeed "disable"
+when_universe No_extensions Succeed "disable"
   Language_extension.disable;
 
-when_disallowed Fail "with_set ~enabled:true"
+when_universe No_extensions Fail "with_set ~enabled:true"
   (Language_extension.with_set ~enabled:true |> lift_with);
 
-when_disallowed Succeed "with_set ~enabled:false"
+when_universe No_extensions Succeed "with_set ~enabled:false"
   (Language_extension.with_set ~enabled:false |> lift_with);
 
-when_disallowed Fail "with_enabled"
+when_universe No_extensions Fail "with_enabled"
   ((fun x -> Language_extension.with_enabled x ()) |> lift_with);
 
-when_disallowed Succeed "with_disabled"
+when_universe No_extensions Succeed "with_disabled"
   (Language_extension.with_disabled |> lift_with);
 
 (* Test explicitly (rather than just via [report]) that [is_enabled] returns
@@ -217,6 +218,38 @@ report
          then "INCORRECTLY enabled"
          else "correctly disabled");
 
+(* Test [Stable] universe. *)
+
+try_setting_universe Stable
+  "can set [Stable] while extensions are disabled";
+
+(* Test that some extensions work in [Stable] while others don't. *)
+
+when_universe Stable Succeed "Language_extension.(enable Layouts Stable)"
+  (fun _ -> Language_extension.(enable Layouts Stable));
+
+when_universe Stable Fail "Language_extension.(enable Comprehensions) "
+  (fun _ -> Language_extension.(enable Comprehensions ()));
+
+when_universe Stable Fail "Language_extension.(enable Layouts Alpha)"
+  (fun _ -> Language_extension.(enable Layouts Alpha));
+
+(* Test [Beta] universe. *)
+
+try_setting_universe Beta "can set [Beta] from [Stable]";
+
+(* Test that comprehensions is enabled by default in [Beta]: *)
+
+typecheck_with_extension "enabled via [Universe.set]";
+
+when_universe Stable Succeed "Language_extension.(enable Comprehensions) "
+  (fun _ -> Language_extension.(enable Comprehensions ()));
+
+(* Test that [Layouts Alpha] is still disabled. *)
+
+when_universe Stable Fail "Language_extension.(enable Layouts Alpha)"
+  (fun _ -> Language_extension.(enable Layouts Alpha));
+
 (* Test that language extensions round-trip via string *)
 List.iter
   (fun (Language_extension.Exist.Pack x) ->

testsuite/tests/language-extensions/language_extensions.reference

@@ -61,36 +61,60 @@ Succeeded
 # Enable two layouts, in reverse order [comprehensions enabled]:
 Succeeded
 
-# can disallow extensions while extensions are enabled [comprehensions disabled]:
-Succeeded at disallowing all extensions
+# can set [No_extensions] while extensions are enabled [comprehensions disabled]:
+Succeeded at setting universe no_extensions
 
-# can disallow extensions while extensions are already disallowed [comprehensions disabled]:
-Succeeded at disallowing all extensions
+# setting [No_extensions] is idempotent [comprehensions disabled]:
+Succeeded at setting universe no_extensions
 
-# can't call [set ~enabled:true] when extensions are disallowed [comprehensions disabled]:
-Failed as expected: Cannot enable extension comprehensions: incompatible with flag -disable-all-extensions
+# can't call [set ~enabled:true] when in universe no_extensions [comprehensions disabled]:
+Failed as expected: Cannot enable extension comprehensions: incompatible with flag -extension-universe no_extensions
 
-# can call [set ~enabled:false] when extensions are disallowed [comprehensions disabled]:
+# can call [set ~enabled:false] when in universe no_extensions [comprehensions disabled]:
 Succeeded at redundantly calling [set ~enabled:false]
 
-# can't call [enable] when extensions are disallowed [comprehensions disabled]:
-Failed as expected: Cannot enable extension comprehensions: incompatible with flag -disable-all-extensions
+# can't call [enable] when in universe no_extensions [comprehensions disabled]:
+Failed as expected: Cannot enable extension comprehensions: incompatible with flag -extension-universe no_extensions
 
-# can call [disable] when extensions are disallowed [comprehensions disabled]:
+# can call [disable] when in universe no_extensions [comprehensions disabled]:
 Succeeded at redundantly calling [disable]
 
-# can't call [with_set ~enabled:true] when extensions are disallowed [comprehensions disabled]:
-Failed as expected: Cannot enable extension comprehensions: incompatible with flag -disable-all-extensions
+# can't call [with_set ~enabled:true] when in universe no_extensions [comprehensions disabled]:
+Failed as expected: Cannot enable extension comprehensions: incompatible with flag -extension-universe no_extensions
 
-# can call [with_set ~enabled:false] when extensions are disallowed [comprehensions disabled]:
+# can call [with_set ~enabled:false] when in universe no_extensions [comprehensions disabled]:
 Succeeded at redundantly calling [with_set ~enabled:false]
 
-# can't call [with_enabled] when extensions are disallowed [comprehensions disabled]:
-Failed as expected: Cannot enable extension comprehensions: incompatible with flag -disable-all-extensions
+# can't call [with_enabled] when in universe no_extensions [comprehensions disabled]:
+Failed as expected: Cannot enable extension comprehensions: incompatible with flag -extension-universe no_extensions
 
-# can call [with_disabled] when extensions are disallowed [comprehensions disabled]:
+# can call [with_disabled] when in universe no_extensions [comprehensions disabled]:
 Succeeded at redundantly calling [with_disabled]
 
 # [is_enabled] returns [false] when extensions are disallowed [comprehensions disabled]:
 "comprehensions" is correctly disabled
 
+# can set [Stable] while extensions are disabled [comprehensions disabled]:
+Succeeded at setting universe stable
+
+# can call [Language_extension.(enable Layouts Stable)] when in universe stable [comprehensions disabled]:
+Succeeded at redundantly calling [Language_extension.(enable Layouts Stable)]
+
+# can't call [Language_extension.(enable Comprehensions) ] when in universe stable [comprehensions disabled]:
+Failed as expected: Cannot enable extension comprehensions: incompatible with flag -extension-universe stable
+
+# can't call [Language_extension.(enable Layouts Alpha)] when in universe stable [comprehensions disabled]:
+Failed as expected: Cannot enable extension layouts_alpha: incompatible with flag -extension-universe stable
+
+# can set [Beta] from [Stable] [comprehensions enabled]:
+Succeeded at setting universe beta
+
+# "comprehensions" extension enabled via [Universe.set] [comprehensions enabled]:
+Successfully typechecked "[x for x = 1 to 10]"
+
+# can call [Language_extension.(enable Comprehensions) ] when in universe stable [comprehensions enabled]:
+Succeeded at redundantly calling [Language_extension.(enable Comprehensions) ]
+
+# can't call [Language_extension.(enable Layouts Alpha)] when in universe stable [comprehensions enabled]:
+Failed as expected: Cannot enable extension layouts_alpha: incompatible with flag -extension-universe beta
+