Add predefined type ['a atomic_loc].

This type will be used for ['a Atomic.Loc.t], as proposed
in the RFC
  ocaml/RFCs#39

We implement this here to be able to use it in the stdlib later,
after a bootstrap.

Author: clef-men

testsuite/tests/match-side-effects/check_partial.ml

@@ -72,7 +72,7 @@ let lazy_needs_partial : _ * bool t ref -> int = function
                 *match*/306 =o (field_mut 0 (field_imm 1 param/298)))
                (if (isint *match*/306) (if *match*/306 12 (exit 3)) (exit 3)))))
         with (3)
-         (raise (makeblock 0 (global Match_failure/20!) [0: "" 1 49])))))
+         (raise (makeblock 0 (global Match_failure/21!) [0: "" 1 49])))))
   (apply (field_mut 1 (global Toploop!)) "lazy_needs_partial"
     lazy_needs_partial/296))
 val lazy_needs_partial : unit lazy_t * bool t ref -> int = <fun>
@@ -91,7 +91,7 @@ let guard_total : bool t ref -> int = function
        (if (opaque 0) 1
          (let (*match*/385 =o (field_mut 0 param/384))
            (if (isint *match*/385) (if *match*/385 12 0)
-             (raise (makeblock 0 (global Match_failure/20!) [0: "" 1 38])))))))
+             (raise (makeblock 0 (global Match_failure/21!) [0: "" 1 38])))))))
   (apply (field_mut 1 (global Toploop!)) "guard_total" guard_total/307))
 val guard_total : bool t ref -> int = <fun>
 |}];;
@@ -111,7 +111,7 @@ let guard_needs_partial : bool t ref -> int = function
           with (9)
            (if (opaque 0) 1
              (if (isint *match*/389) 12
-               (raise (makeblock 0 (global Match_failure/20!) [0: "" 1 46]))))))))
+               (raise (makeblock 0 (global Match_failure/21!) [0: "" 1 46]))))))))
   (apply (field_mut 1 (global Toploop!)) "guard_needs_partial"
     guard_needs_partial/386))
 val guard_needs_partial : bool t ref -> int = <fun>

testsuite/tests/match-side-effects/partiality.ml

@@ -49,7 +49,7 @@ Warning 74 [degraded-to-partial-match]: This pattern-matching is compiled as
                (let (*match*/288 =o (field_mut 1 x/283))
                  (if *match*/288 (field_imm 0 *match*/288)
                    (raise
-                     (makeblock 0 (global Match_failure/20!) [0: "" 4 2])))))
+                     (makeblock 0 (global Match_failure/21!) [0: "" 4 2])))))
              1))
          0)))
   (apply (field_mut 1 (global Toploop!)) "f" f/281))
@@ -111,7 +111,7 @@ Warning 74 [degraded-to-partial-match]: This pattern-matching is compiled as
            (if *match*/303 (field_imm 0 *match*/303)
              (let (*match*/304 =o (field_mut 1 x/299))
                (if *match*/304
-                 (raise (makeblock 0 (global Match_failure/20!) [0: "" 2 2]))
+                 (raise (makeblock 0 (global Match_failure/21!) [0: "" 2 2]))
                  1))))
          0)))
   (apply (field_mut 1 (global Toploop!)) "f" f/298))
@@ -160,7 +160,7 @@ Warning 74 [degraded-to-partial-match]: This pattern-matching is compiled as
                (let (*match*/312 =o (field_mut 0 (field_imm 0 *match*/308)))
                  (if *match*/312 (field_imm 0 *match*/312)
                    (raise
-                     (makeblock 0 (global Match_failure/20!) [0: "" 2 2]))))
+                     (makeblock 0 (global Match_failure/21!) [0: "" 2 2]))))
                3))))))
   (apply (field_mut 1 (global Toploop!)) "f" f/305))
 
@@ -293,7 +293,7 @@ Warning 74 [degraded-to-partial-match]: This pattern-matching is compiled as
                   *match*/354 =a (field_imm 1 *match*/352))
                  (if *match*/354 (field_imm 0 *match*/354)
                    (raise
-                     (makeblock 0 (global Match_failure/20!) [0: "" 2 2]))))
+                     (makeblock 0 (global Match_failure/21!) [0: "" 2 2]))))
                3))))))
   (apply (field_mut 1 (global Toploop!)) "deep" deep/342))
 

testsuite/tests/match-side-effects/test_contexts_code.ml

@@ -44,7 +44,7 @@ let example_1 () =
                     case tag 0: (makeblock 0 (int) (field_imm 0 *match*/340))
                     case tag 1:
                      (raise
-                       (makeblock 0 (global Match_failure/20!)
+                       (makeblock 0 (global Match_failure/21!)
                          [0: "contexts_1.ml" 17 2])))))
               case tag 1: [1: 2]))
            [1: 1]))))
@@ -91,7 +91,7 @@ let example_2 () =
                     case tag 0: (makeblock 0 (int) (field_imm 0 *match*/358))
                     case tag 1:
                      (raise
-                       (makeblock 0 (global Match_failure/20!)
+                       (makeblock 0 (global Match_failure/21!)
                          [0: "contexts_2.ml" 11 2])))))
               case tag 1: [1: 2]))
            [1: 1]))))

typing/predef.ml

@@ -42,6 +42,7 @@ type abstract_type_constr = [
   | `Lazy_t
   | `Extension_constructor
   | `Floatarray
+  | `Atomic_loc
 ]
 type data_type_constr = [
   | `Bool
@@ -56,7 +57,7 @@ type type_constr = [
   | data_type_constr
 ]
 
-let all_type_constrs = [
+let all_type_constrs : type_constr list = [
   `Int;
   `Char;
   `String;
@@ -76,6 +77,7 @@ let all_type_constrs = [
   `Lazy_t;
   `Extension_constructor;
   `Floatarray;
+  `Atomic_loc;
 ]
 
 let ident_int = ident_create "int"
@@ -97,8 +99,9 @@ and ident_lazy_t = ident_create "lazy_t"
 and ident_string = ident_create "string"
 and ident_extension_constructor = ident_create "extension_constructor"
 and ident_floatarray = ident_create "floatarray"
+and ident_atomic_loc = ident_create "atomic_loc"
 
-let ident_of_type_constr = function
+let ident_of_type_constr : type_constr -> Ident.t = function
   | `Int -> ident_int
   | `Char -> ident_char
   | `String -> ident_string
@@ -118,6 +121,7 @@ let ident_of_type_constr = function
   | `Lazy_t -> ident_lazy_t
   | `Extension_constructor -> ident_extension_constructor
   | `Floatarray -> ident_floatarray
+  | `Atomic_loc -> ident_atomic_loc
 
 let path_int = Pident ident_int
 and path_char = Pident ident_char
@@ -138,6 +142,7 @@ and path_lazy_t = Pident ident_lazy_t
 and path_string = Pident ident_string
 and path_extension_constructor = Pident ident_extension_constructor
 and path_floatarray = Pident ident_floatarray
+and path_atomic_loc = Pident ident_atomic_loc
 
 let path_of_type_constr typ =
   Pident (ident_of_type_constr typ)
@@ -162,6 +167,7 @@ and type_lazy_t t = tconstr path_lazy_t [t]
 and type_string = tconstr path_string []
 and type_extension_constructor = tconstr path_extension_constructor []
 and type_floatarray = tconstr path_floatarray []
+and type_atomic_loc t = tconstr path_atomic_loc [t]
 
 let find_type_constr =
   let all_predef_paths =
@@ -300,7 +306,9 @@ let decl_of_type_constr tconstr =
   | `Continuation ->
       let variance = Variance.(contravariant, covariant) in
       decl2 ~variance ()
-  | `Array ->
+  | `Array
+  | `Atomic_loc
+    ->
       decl1 ~variance:Variance.full ()
   | `List ->
       let kind tvar =

typing/predef.mli

@@ -31,6 +31,7 @@ type abstract_type_constr = [
   | `Lazy_t
   | `Extension_constructor
   | `Floatarray
+  | `Atomic_loc
 ]
 type data_type_constr = [
   | `Bool
@@ -64,8 +65,9 @@ val type_nativeint: type_expr
 val type_int32: type_expr
 val type_int64: type_expr
 val type_lazy_t: type_expr -> type_expr
-val type_extension_constructor:type_expr
-val type_floatarray:type_expr
+val type_extension_constructor: type_expr
+val type_floatarray: type_expr
+val type_atomic_loc: type_expr -> type_expr
 
 val path_int: Path.t
 val path_char: Path.t

typing/typeopt.ml

@@ -97,7 +97,7 @@ let classify env ty : classification =
       | Some (`String | `Bytes
              | `Int32 | `Int64 | `Nativeint
              | `Extension_constructor | `Continuation
-             | `Array | `Floatarray)
+             | `Array | `Floatarray | `Atomic_loc)
         -> Addr
       | Some #Predef.data_type_constr | None ->
         try