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 @@ exception. This typically occurs due to complex matches on mutable fields.
                (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 @@ exception. This typically occurs due to complex matches on mutable fields.
            (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 @@ exception. This typically occurs due to complex matches on mutable fields.
                (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 @@ exception. This typically occurs due to complex matches on mutable fields.
                   *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

@@ -47,6 +47,7 @@ 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 path_int = Pident ident_int
 and path_char = Pident ident_char
@@ -67,6 +68,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 type_int = newgenty (Tconstr(path_int, [], ref Mnil))
 and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
@@ -89,6 +91,7 @@ and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
 and type_extension_constructor =
       newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
 and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil))
+and type_atomic_loc t = newgenty (Tconstr(path_atomic_loc, [t], ref Mnil))
 
 let ident_match_failure = ident_create "Match_failure"
 and ident_out_of_memory = ident_create "Out_of_memory"
@@ -244,6 +247,9 @@ let build_initial_env add_type add_extension empty_env =
   |> add_type ident_extension_constructor
   |> add_type ident_float
   |> add_type ident_floatarray
+  |> add_type1 ident_atomic_loc
+       ~variance:Variance.full
+       ~separability:Separability.Ind
   |> add_type ident_int ~immediate:Always
   |> add_type ident_int32
   |> add_type ident_int64

typing/predef.mli

@@ -34,8 +34,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