flambda-backend: Factor out kernel of Language_extension used by Ja…

…ne Syntax (#1509)

* Make Jane Syntax depend on less of `Language_extension`

* Add new module to compilerlibs

* Fix broken dependencies

* improve comments

* Remove dependency of [Jane_syntax_parsing] on a binding that isn't available in upstream ocaml

* Adapt comments from review: implicitly functorize over a smaller number of bindings

* co-locate extension names

.depend

@@ -129,11 +129,20 @@ utils/int_replace_polymorphic_compare.cmx : \
 utils/int_replace_polymorphic_compare.cmi :
 utils/language_extension.cmo : \
     utils/misc.cmi \
+    utils/language_extension_kernel.cmi \
     utils/language_extension.cmi
 utils/language_extension.cmx : \
     utils/misc.cmx \
+    utils/language_extension_kernel.cmx \
     utils/language_extension.cmi
-utils/language_extension.cmi :
+utils/language_extension.cmi : \
+    utils/language_extension_kernel.cmi
+utils/language_extension_kernel.cmo : \
+    utils/language_extension_kernel.cmi
+utils/language_extension_kernel.cmx : \
+    utils/language_extension_kernel.cmi
+utils/language_extension_kernel.cmi :
+utils/language_extension_kernel_intf.cmi :
 utils/lazy_backtrack.cmo : \
     utils/lazy_backtrack.cmi
 utils/lazy_backtrack.cmx : \
@@ -315,7 +324,6 @@ parsing/ast_mapper.cmo : \
     parsing/longident.cmi \
     parsing/location.cmi \
     utils/load_path.cmi \
-    parsing/jane_syntax_parsing.cmi \
     parsing/jane_syntax.cmi \
     utils/config.cmi \
     utils/clflags.cmi \
@@ -328,7 +336,6 @@ parsing/ast_mapper.cmx : \
     parsing/longident.cmx \
     parsing/location.cmx \
     utils/load_path.cmx \
-    parsing/jane_syntax_parsing.cmx \
     parsing/jane_syntax.cmx \
     utils/config.cmx \
     utils/clflags.cmx \
@@ -450,19 +457,18 @@ parsing/jane_syntax.cmi : \
     parsing/parsetree.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
-    parsing/jane_syntax_parsing.cmi \
     parsing/asttypes.cmi
 parsing/jane_syntax_parsing.cmo : \
     parsing/parsetree.cmi \
-    utils/misc.cmi \
     parsing/location.cmi \
+    utils/language_extension_kernel.cmi \
     utils/language_extension.cmi \
     parsing/ast_helper.cmi \
     parsing/jane_syntax_parsing.cmi
 parsing/jane_syntax_parsing.cmx : \
     parsing/parsetree.cmi \
-    utils/misc.cmx \
     parsing/location.cmx \
+    utils/language_extension_kernel.cmx \
     utils/language_extension.cmx \
     parsing/ast_helper.cmx \
     parsing/jane_syntax_parsing.cmi
@@ -534,6 +540,7 @@ parsing/parser.cmo : \
     parsing/parsetree.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
+    utils/language_extension.cmi \
     parsing/jane_syntax_parsing.cmi \
     parsing/jane_syntax.cmi \
     parsing/docstrings.cmi \
@@ -548,6 +555,7 @@ parsing/parser.cmx : \
     parsing/parsetree.cmi \
     parsing/longident.cmx \
     parsing/location.cmx \
+    utils/language_extension.cmx \
     parsing/jane_syntax_parsing.cmx \
     parsing/jane_syntax.cmx \
     parsing/docstrings.cmx \
@@ -1663,6 +1671,7 @@ typing/typedecl.cmo : \
     parsing/longident.cmi \
     parsing/location.cmi \
     typing/layouts.cmi \
+    parsing/jane_syntax.cmi \
     typing/includecore.cmi \
     typing/ident.cmi \
     typing/errortrace.cmi \
@@ -1696,6 +1705,7 @@ typing/typedecl.cmx : \
     parsing/longident.cmx \
     parsing/location.cmx \
     typing/layouts.cmx \
+    parsing/jane_syntax.cmx \
     typing/includecore.cmx \
     typing/ident.cmx \
     typing/errortrace.cmx \
@@ -2088,7 +2098,6 @@ typing/untypeast.cmo : \
     parsing/parsetree.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
-    parsing/jane_syntax_parsing.cmi \
     parsing/jane_syntax.cmi \
     typing/ident.cmi \
     typing/env.cmi \
@@ -2101,7 +2110,6 @@ typing/untypeast.cmx : \
     parsing/parsetree.cmi \
     parsing/longident.cmx \
     parsing/location.cmx \
-    parsing/jane_syntax_parsing.cmx \
     parsing/jane_syntax.cmx \
     typing/ident.cmx \
     typing/env.cmx \

compilerlibs/Makefile.compilerlibs

@@ -35,6 +35,7 @@ UTILS = \
   utils/load_path.cmo \
   utils/clflags.cmo \
   utils/debug.cmo \
+  utils/language_extension_kernel.cmo \
   utils/language_extension.cmo \
   utils/profile.cmo \
   utils/terminfo.cmo \
@@ -53,7 +54,7 @@ UTILS = \
   utils/lazy_backtrack.cmo \
   utils/diffing.cmo \
   utils/diffing_with_keys.cmo
-UTILS_CMI =
+UTILS_CMI = \
 
 PARSING = \
   parsing/location.cmo \

dune

@@ -58,7 +58,8 @@
    debug profile terminfo ccomp warnings consistbl strongly_connected_components
    targetint load_path int_replace_polymorphic_compare domainstate binutils
    local_store target_system compilation_unit import_info linkage_name symbol
-   lazy_backtrack diffing diffing_with_keys language_extension
+   lazy_backtrack diffing diffing_with_keys
+   language_extension_kernel language_extension
 
    ;; PARSING
    location longident docstrings syntaxerr ast_helper camlinternalMenhirLib

otherlibs/dynlink/Makefile

@@ -82,6 +82,7 @@ COMPILERLIBS_SOURCES=\
   utils/load_path.ml \
   utils/clflags.ml \
   utils/debug.ml \
+  utils/language_extension_kernel.ml \
   utils/language_extension.ml \
   utils/profile.ml \
   utils/consistbl.ml \

otherlibs/dynlink/dune

@@ -32,6 +32,7 @@
     arg_helper
     clflags
     debug
+    language_extension_kernel
     language_extension
     profile
     consistbl
@@ -111,6 +112,7 @@
 (copy_files ../../utils/arg_helper.ml)
 (copy_files ../../utils/clflags.ml)
 (copy_files ../../utils/debug.ml)
+(copy_files ../../utils/language_extension_kernel.ml)
 (copy_files ../../utils/language_extension.ml)
 (copy_files ../../utils/profile.ml)
 (copy_files ../../utils/consistbl.ml)
@@ -168,6 +170,7 @@
 (copy_files ../../utils/arg_helper.mli)
 (copy_files ../../utils/clflags.mli)
 (copy_files ../../utils/debug.mli)
+(copy_files ../../utils/language_extension_kernel.mli)
 (copy_files ../../utils/language_extension.mli)
 (copy_files ../../utils/profile.mli)
 (copy_files ../../utils/consistbl.mli)
@@ -267,6 +270,7 @@
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Profile.cmo
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Clflags.cmo
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Debug.cmo
+      .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Language_extension_kernel.cmo
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Language_extension.cmo
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Terminfo.cmo
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Location.cmo
@@ -339,6 +343,7 @@
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Profile.cmx
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Clflags.cmx
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Debug.cmx
+      .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Language_extension_kernel.cmx
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Language_extension.cmx
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Terminfo.cmx
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Location.cmx

parsing/jane_syntax_parsing.ml

@@ -79,6 +79,17 @@
 
 open Parsetree
 
+(** We carefully regulate which bindings we import from [Language_extension]
+    to ensure that we can import this file into the Jane Street internal
+    repo with no changes.
+*)
+module Language_extension = struct
+  include Language_extension_kernel
+  include (
+    Language_extension
+      : Language_extension_kernel.Language_extension_for_jane_syntax)
+end
+
 (******************************************************************************)
 
 module Feature : sig
@@ -777,7 +788,7 @@ module Make_ast (AST : AST_internal) : AST with type ast = AST.ast = struct
   let make_entire_jane_syntax ~loc feature ast =
     AST.with_location
       (make_jane_syntax feature []
-         (Ast_helper.with_default_loc (Location.ghostify loc) ast))
+         (Ast_helper.with_default_loc { loc with loc_ghost = true } ast))
       loc
 
   (** Generically lift our custom ASTs for our novel syntax from OCaml ASTs. *)

tools/Makefile

@@ -86,7 +86,8 @@ OCAMLPROF=config.cmo build_path_prefix_map.cmo misc.cmo identifiable.cmo \
   numbers.cmo arg_helper.cmo clflags.cmo debug.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
   syntaxerr.cmo ast_helper.cmo \
-  language_extension.cmo jane_syntax_parsing.cmo jane_syntax.cmo \
+  language_extension_kernel.cmo language_extension.cmo \
+  jane_syntax_parsing.cmo jane_syntax.cmo \
    ast_iterator.cmo builtin_attributes.cmo \
   camlinternalMenhirLib.cmo parser.cmo \
   pprintast.cmo \
@@ -99,7 +100,8 @@ opt.opt: profiling.cmx
 
 OCAMLCP = config.cmo build_path_prefix_map.cmo misc.cmo profile.cmo \
           warnings.cmo identifiable.cmo numbers.cmo arg_helper.cmo \
-          language_extension.cmo clflags.cmo local_store.cmo \
+          language_extension_kernel.cmo language_extension.cmo \
+	  clflags.cmo local_store.cmo \
           terminfo.cmo location.cmo load_path.cmo ccomp.cmo compenv.cmo \
           main_args.cmo
 

utils/language_extension.ml

@@ -1,3 +1,5 @@
+include Language_extension_kernel
+
 (* operations we want on every extension level *)
 module type Extension_level = sig
   type t
@@ -18,7 +20,7 @@ module Unit = struct
 end
 
 module Maturity = struct
-  type t = Stable | Beta | Alpha
+  type t = maturity = Stable | Beta | Alpha
 
   let compare t1 t2 =
     let rank = function
@@ -39,34 +41,6 @@ module Maturity = struct
     | Alpha -> "_alpha"
 end
 
-type maturity = Maturity.t = Stable | Beta | Alpha
-
-(* Remember to update [all] when changing this type. *)
-type _ t =
-  | Comprehensions : unit t
-  | Local : unit t
-  | Include_functor : unit t
-  | Polymorphic_parameters : unit t
-  | Immutable_arrays : unit t
-  | Module_strengthening : unit t
-  | Layouts : Maturity.t t
-
-type exist =
-  Pack : _ t -> exist
-
-let all : exist list =
-  [ Pack Comprehensions
-  ; Pack Local
-  ; Pack Include_functor
-  ; Pack Polymorphic_parameters
-  ; Pack Immutable_arrays
-  ; Pack Module_strengthening
-  ; Pack Layouts
-  ]
-
-type extn_pair =
-  | Pair : 'a t * 'a -> extn_pair
-
 let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   function
   | Comprehensions -> (module Unit)
@@ -77,47 +51,17 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   | Module_strengthening -> (module Unit)
   | Layouts -> (module Maturity)
 
+type extn_pair = Exist_pair.t = Pair : 'a t * 'a -> extn_pair
+type exist = Exist.t = Pack : _ t -> exist
+
 (**********************************)
 (* string conversions *)
 
-let to_string : type a. a t -> string = function
-  | Comprehensions -> "comprehensions"
-  | Local -> "local"
-  | Include_functor -> "include_functor"
-  | Polymorphic_parameters -> "polymorphic_parameters"
-  | Immutable_arrays -> "immutable_arrays"
-  | Module_strengthening -> "module_strengthening"
-  | Layouts -> "layouts"
-
-(* converts full extension names, like "layouts_alpha" to a pair of
-   an extension and its setting *)
-let pair_of_string extn_name : extn_pair option =
-  match String.lowercase_ascii extn_name with
-  | "comprehensions" -> Some (Pair (Comprehensions, ()))
-  | "local" -> Some (Pair (Local, ()))
-  | "include_functor" -> Some (Pair (Include_functor, ()))
-  | "polymorphic_parameters" -> Some (Pair (Polymorphic_parameters, ()))
-  | "immutable_arrays" -> Some (Pair (Immutable_arrays, ()))
-  | "module_strengthening" -> Some (Pair (Module_strengthening, ()))
-  | "layouts" -> Some (Pair (Layouts, (Stable : Maturity.t)))
-  | "layouts_beta" -> Some (Pair (Layouts, (Beta : Maturity.t)))
-  | "layouts_alpha" -> Some (Pair (Layouts, (Alpha : Maturity.t)))
-  | _ -> None
-
 let pair_of_string_exn extn_name = match pair_of_string extn_name with
   | Some pair -> pair
   | None ->
     raise (Arg.Bad(Printf.sprintf "Extension %s is not known" extn_name))
 
-let of_string extn_name =
-  let pack (Pair (extn, _) : extn_pair) = Pack extn in
-  Option.map pack (pair_of_string extn_name)
-
-let maturity_to_string = function
-  | Alpha -> "alpha"
-  | Beta -> "beta"
-  | Stable -> "stable"
-
 (************************************)
 (* equality *)
 
@@ -137,25 +81,6 @@ let equal a b = Option.is_some (equal_t a b)
 (*****************************)
 (* extension universes *)
 
-(* We'll do this in a more principled way later. *)
-(* CR layouts: Note that layouts is only "mostly" erasable, because of annoying
-   interactions with the pre-layouts [@@immediate] attribute like:
-
-     type ('a : immediate) t = 'a [@@immediate]
-
-   But we've decided to punt on this issue in the short term.
-*)
-let is_erasable : type a. a t -> bool = function
-  | Local
-  | Layouts ->
-      true
-  | Comprehensions
-  | Include_functor
-  | Polymorphic_parameters
-  | Immutable_arrays
-  | Module_strengthening ->
-      false
-
 module Universe : sig
   val is_allowed : 'a t -> bool
   val check : 'a t -> unit
@@ -304,7 +229,7 @@ let enable_maximal () =
     let (module Ops) = get_level_ops extn in
     Pair (extn, Ops.max_value)
   in
-  extensions := List.map maximal_pair all
+  extensions := List.map maximal_pair Exist.all
 
 let restrict_to_erasable_extensions () =
   let changed = Universe.set Only_erasable in
@@ -340,9 +265,7 @@ let is_enabled extn =
 
 
 module Exist = struct
-  type 'a extn = 'a t
-  type t = exist =
-    | Pack : 'a extn -> t
+  include Exist
 
   let to_command_line_strings (Pack extn) =
     let (module Ops) = get_level_ops extn in
@@ -358,6 +281,4 @@ module Exist = struct
 
   let is_erasable : t -> bool = function
     | Pack extn -> is_erasable extn
-
-  let all = all
 end