flambda-backend: New extensions API, supporting maturity levels (#1454)

* New extensions API, supporting for maturity levels

* Fix ocamldoc failure

* Nick's suggestions, plus some cleaning up

* Refactor [fail] in the style of [Base.failwithf]

---------

Co-authored-by: Nick Roberts <[email protected]>

Author: goldfirere

.depend

@@ -128,8 +128,10 @@ utils/int_replace_polymorphic_compare.cmx : \
     utils/int_replace_polymorphic_compare.cmi
 utils/int_replace_polymorphic_compare.cmi :
 utils/language_extension.cmo : \
+    utils/misc.cmi \
     utils/language_extension.cmi
 utils/language_extension.cmx : \
+    utils/misc.cmx \
     utils/language_extension.cmi
 utils/language_extension.cmi :
 utils/lazy_backtrack.cmo : \
@@ -534,6 +536,7 @@ parsing/parser.cmo : \
     parsing/parsetree.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
+    parsing/jane_syntax_parsing.cmi \
     parsing/jane_syntax.cmi \
     parsing/docstrings.cmi \
     utils/clflags.cmi \
@@ -547,6 +550,7 @@ parsing/parser.cmx : \
     parsing/parsetree.cmi \
     parsing/longident.cmx \
     parsing/location.cmx \
+    parsing/jane_syntax_parsing.cmx \
     parsing/jane_syntax.cmx \
     parsing/docstrings.cmx \
     utils/clflags.cmx \
@@ -2030,6 +2034,7 @@ typing/typetexp.cmo : \
     parsing/location.cmi \
     typing/layouts.cmi \
     utils/language_extension.cmi \
+    parsing/jane_syntax.cmi \
     typing/errortrace.cmi \
     typing/env.cmi \
     typing/ctype.cmi \
@@ -2053,6 +2058,7 @@ typing/typetexp.cmx : \
     parsing/location.cmx \
     typing/layouts.cmx \
     utils/language_extension.cmx \
+    parsing/jane_syntax.cmx \
     typing/errortrace.cmx \
     typing/env.cmx \
     typing/ctype.cmx \
@@ -6803,6 +6809,7 @@ toplevel/topcommon.cmi : \
     typing/outcometree.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
+    typing/layouts.cmi \
     typing/ident.cmi \
     toplevel/genprintval.cmi \
     typing/env.cmi \
@@ -7078,7 +7085,6 @@ toplevel/native/topeval.cmo : \
     parsing/location.cmi \
     utils/load_path.cmi \
     utils/linkage_name.cmi \
-    typing/layouts.cmi \
     lambda/lambda.cmi \
     typing/includemod.cmi \
     typing/ident.cmi \
@@ -7112,7 +7118,6 @@ toplevel/native/topeval.cmx : \
     parsing/location.cmx \
     utils/load_path.cmx \
     utils/linkage_name.cmx \
-    typing/layouts.cmx \
     lambda/lambda.cmx \
     typing/includemod.cmx \
     typing/ident.cmx \

boot/menhir/parser.ml

@@ -995,7 +995,13 @@ let check_layout loc id =
 
 (* Unboxed literals *)
 
-let unboxed_literals_extension : Language_extension.t = Layouts Alpha
+(* CR layouts v2: The [unboxed_*] functions will both be improved and lose
+   their explicit assert once we have real unboxed literals in Jane syntax; they
+   may also get re-inlined at that point *)
+let unboxed_literals_extension = Language_extension.Layouts
+let assert_unboxed_literals ~loc =
+  Language_extension.(
+    Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha)
 
 type sign = Positive | Negative
 
@@ -1004,15 +1010,10 @@ let with_sign sign num =
   | Positive -> num
   | Negative -> "-" ^ num
 
-(* CR layouts ASZ: The [unboxed_*] functions will both be improved and lose
-   their explicit assert once we have real unboxed literals in Jane syntax; they
-   may also get re-inlined at that point *)
-
 let unboxed_int sloc int_loc sign (n, m) =
   match m with
   | Some _ ->
-      Jane_syntax_parsing.assert_extension_enabled
-        ~loc:(make_loc sloc) unboxed_literals_extension;
+      assert_unboxed_literals ~loc:(make_loc sloc);
       Pconst_integer (with_sign sign n, m)
   | None ->
       if Language_extension.is_enabled unboxed_literals_extension then
@@ -1021,8 +1022,7 @@ let unboxed_int sloc int_loc sign (n, m) =
         not_expecting sloc "line number directive"
 
 let unboxed_float sloc sign (f, m) =
-  Jane_syntax_parsing.assert_extension_enabled
-    ~loc:(make_loc sloc) unboxed_literals_extension;
+  assert_unboxed_literals ~loc:(make_loc sloc);
   Pconst_float (with_sign sign f, m)
 
 (* Jane syntax *)

driver/compenv.ml

@@ -490,7 +490,7 @@ let read_one_param ppf position name v =
   | "dump-into-file" -> Clflags.dump_into_file := true
   | "dump-dir" -> Clflags.dump_dir := Some v
 
-  | "extension" -> Language_extension.(enable (of_string_exn v))
+  | "extension" -> Language_extension.enable_of_string_exn v
   | "disable-all-extensions" ->
     if check_bool ppf name v then Language_extension.disallow_extensions ()
 

driver/main_args.ml

@@ -732,15 +732,15 @@ let mk_dump_into_file f =
 
 let mk_extension f =
   let available_extensions =
-    Language_extension.(List.map to_string all)
+    Language_extension.Exist.(List.concat_map to_command_line_strings all)
   in
   "-extension", Arg.Symbol (available_extensions, f),
   "  Enable the specified extension (may be specified more than once)"
 ;;
 
 let mk_no_extension f =
   let available_extensions =
-    Language_extension.(List.map to_string all)
+    Language_extension.Exist.(List.concat_map to_command_line_strings all)
   in
   "-no-extension", Arg.Symbol (available_extensions, f),
   "  Disable the specified extension (may be specified more than once)"
@@ -756,8 +756,11 @@ let mk_disable_all_extensions f =
 
 let mk_only_erasable_extensions f =
   let erasable_extensions =
-    let open Language_extension in
-    all |> List.filter is_erasable |> List.map to_string |> String.concat ", "
+    let open Language_extension.Exist in
+    all |>
+    List.filter is_erasable |>
+    List.concat_map to_command_line_strings |>
+    String.concat ", "
   in
 "-only-erasable-extensions", Arg.Unit f,
   "  Disable all extensions that cannot be \"erased\" to attributes,\n\
@@ -1818,8 +1821,8 @@ module Default = struct
     let _disable_all_extensions = Language_extension.disallow_extensions
     let _only_erasable_extensions =
       Language_extension.restrict_to_erasable_extensions
-    let _extension s = Language_extension.(enable (of_string_exn s))
-    let _no_extension s = Language_extension.(disable (of_string_exn s))
+    let _extension s = Language_extension.(enable_of_string_exn s)
+    let _no_extension s = Language_extension.(disable_of_string_exn s)
     let _noassert = set noassert
     let _nolabels = set classic
     let _nostdlib = set no_std_include

driver/makedepend.ml

@@ -662,7 +662,7 @@ 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;
-    List.iter Language_extension.enable Language_extension.max_compatible;
+    Language_extension.enable_maximal ();
     process_dep_args (List.rev !dep_args_rev);
     Compenv.readenv ppf Before_link;
     if !sort_files then sort_files_by_dependencies !files

parsing/builtin_attributes.ml

@@ -478,10 +478,9 @@ let layout ~legacy_immediate attrs =
      | Value -> check true
      | Immediate | Immediate64 ->
         check  (legacy_immediate
-             || Language_extension.(   is_enabled (Layouts Beta)
-                                    || is_enabled (Layouts Alpha)))
+             || Language_extension.(is_at_least Layouts Beta))
      | Any | Void ->
-        check (Language_extension.is_enabled (Layouts Alpha))
+        check Language_extension.(is_at_least Layouts Alpha)
 
 (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
    attributes cannot be input by the user, they are added by the

parsing/jane_syntax.ml

@@ -268,7 +268,7 @@ module Comprehensions = struct
       | ["array"; "immutable"], Pexp_lazy comp ->
           (* assert_extension_enabled:
             See Note [Check for immutable extension in comprehensions code] *)
-          assert_extension_enabled ~loc:expr.pexp_loc Immutable_arrays;
+          assert_extension_enabled ~loc:expr.pexp_loc Immutable_arrays ();
           Cexp_array_comprehension (Immutable, comprehension_of_expr comp)
       | bad, _ ->
           Desugaring_error.raise expr (Bad_comprehension_embedding bad)

parsing/jane_syntax_parsing.ml

@@ -83,11 +83,11 @@ open Parsetree
 
 module Feature : sig
   type t =
-    | Language_extension of Language_extension.t
+    | Language_extension : _ Language_extension.t -> t
     | Builtin
 
   type error =
-    | Disabled_extension of Language_extension.t
+    | Disabled_extension : _ Language_extension.t -> error
     | Unknown_extension of string
 
   val describe_uppercase : t -> string
@@ -98,11 +98,11 @@ module Feature : sig
 
   val is_erasable : t -> bool
 end = struct
-  type t = Language_extension of Language_extension.t
+  type t = Language_extension : _ Language_extension.t -> t
          | Builtin
 
   type error =
-    | Disabled_extension of Language_extension.t
+    | Disabled_extension : _ Language_extension.t -> error
     | Unknown_extension of string
 
   let builtin_component = "_builtin"
@@ -122,10 +122,10 @@ end = struct
       Ok Builtin
     else
       match Language_extension.of_string str with
-      | Some ext when Language_extension.is_enabled ext ->
-          Ok (Language_extension ext)
-      | Some ext ->
-          Error (Disabled_extension ext)
+      | Some (Pack ext) ->
+          if Language_extension.is_enabled ext
+          then Ok (Language_extension ext)
+          else Error (Disabled_extension ext)
       | None ->
           Error (Unknown_extension str)
 
@@ -334,7 +334,7 @@ module Error = struct
     | Malformed_embedding of
         Embedding_syntax.t * Embedded_name.t * malformed_embedding
     | Unknown_extension of Embedding_syntax.t * Erasability.t * string
-    | Disabled_extension of Language_extension.t
+    | Disabled_extension : _ Language_extension.t -> error
     | Wrong_syntactic_category of Feature.t * string
     | Misnamed_embedding of
         Misnamed_embedding_error.t * string * Embedding_syntax.t
@@ -347,8 +347,8 @@ end
 
 open Error
 
-let assert_extension_enabled ~loc ext =
-  if not (Language_extension.is_enabled ext) then
+let assert_extension_enabled ~loc ext setting =
+  if not (Language_extension.is_at_least ext setting) then
     raise (Error(loc, Disabled_extension ext))
 ;;
 

parsing/jane_syntax_parsing.mli

@@ -94,7 +94,7 @@
     built-in features. *)
 module Feature : sig
   type t =
-    | Language_extension of Language_extension.t
+    | Language_extension : _ Language_extension.t -> t
     | Builtin
 
   (** The component of an attribute or extension name that identifies the
@@ -238,13 +238,14 @@ module AST : sig
     -> ('ast -> 'a option)
 end
 
-(** Require that an extension is enabled, or else throw an exception (of an
-    abstract type) at the provided location saying otherwise.  This is intended
-    to be used in [jane_syntax.ml] when a certain piece of syntax requires two
-    extensions to be enabled at once (e.g., immutable array comprehensions such
-    as [[:x for x = 1 to 10:]], which require both [Comprehensions] and
-    [Immutable_arrays]). *)
-val assert_extension_enabled : loc:Location.t -> Language_extension.t -> unit
+(** Require that an extension is enabled for at least the provided level, or
+    else throw an exception (of an abstract type) at the provided location
+    saying otherwise.  This is intended to be used in [jane_syntax.ml] when a
+    certain piece of syntax requires two extensions to be enabled at once (e.g.,
+    immutable array comprehensions such as [[:x for x = 1 to 10:]], which
+    require both [Comprehensions] and [Immutable_arrays]). *)
+val assert_extension_enabled :
+  loc:Location.t -> 'a Language_extension.t -> 'a -> unit
 
 (* CR-someday nroberts: An earlier version of this revealed less of its
    implementation in its name: it was called [match_jane_syntax], and

parsing/parser.mly

@@ -782,7 +782,13 @@ let check_layout loc id =
 
 (* Unboxed literals *)
 
-let unboxed_literals_extension : Language_extension.t = Layouts Alpha
+(* CR layouts v2: The [unboxed_*] functions will both be improved and lose
+   their explicit assert once we have real unboxed literals in Jane syntax; they
+   may also get re-inlined at that point *)
+let unboxed_literals_extension = Language_extension.Layouts
+let assert_unboxed_literals ~loc =
+  Language_extension.(
+    Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha)
 
 type sign = Positive | Negative
 
@@ -791,15 +797,10 @@ let with_sign sign num =
   | Positive -> num
   | Negative -> "-" ^ num
 
-(* CR layouts ASZ: The [unboxed_*] functions will both be improved and lose
-   their explicit assert once we have real unboxed literals in Jane syntax; they
-   may also get re-inlined at that point *)
-
 let unboxed_int sloc int_loc sign (n, m) =
   match m with
   | Some _ ->
-      Jane_syntax_parsing.assert_extension_enabled
-        ~loc:(make_loc sloc) unboxed_literals_extension;
+      assert_unboxed_literals ~loc:(make_loc sloc);
       Pconst_integer (with_sign sign n, m)
   | None ->
       if Language_extension.is_enabled unboxed_literals_extension then
@@ -808,8 +809,7 @@ let unboxed_int sloc int_loc sign (n, m) =
         not_expecting sloc "line number directive"
 
 let unboxed_float sloc sign (f, m) =
-  Jane_syntax_parsing.assert_extension_enabled
-    ~loc:(make_loc sloc) unboxed_literals_extension;
+  assert_unboxed_literals ~loc:(make_loc sloc);
   Pconst_float (with_sign sign f, m)
 
 (* Jane syntax *)

testsuite/tests/ast-invariants/test.ml

@@ -85,5 +85,5 @@ let rec walk dir =
     (Sys.readdir dir)
 
 let () =
-  List.iter Language_extension.enable Language_extension.max_compatible;
+  Language_extension.enable_maximal ();
   walk root

testsuite/tests/comprehensions/syntax.ml

@@ -1,7 +1,7 @@
 (* TEST
    include ocamlcommon *)
 
-let () = Language_extension.enable Comprehensions;;
+let () = Language_extension.enable Comprehensions ();;
 
 let printf = Printf.printf;;