Allow arguments to primitives to be local even in tail position (#53)

Also improves local annotations on stdlib to_int primitives

Author: stedolan

stdlib/int32.ml

@@ -28,7 +28,7 @@ external shift_left : (int32[@local_opt]) -> int -> (int32[@local_opt]) = "%int3
 external shift_right : (int32[@local_opt]) -> int -> (int32[@local_opt]) = "%int32_asr"
 external shift_right_logical : (int32[@local_opt]) -> int -> (int32[@local_opt]) = "%int32_lsr"
 external of_int : int -> (int32[@local_opt]) = "%int32_of_int"
-external to_int : int32 -> int = "%int32_to_int"
+external to_int : (int32[@local_opt]) -> int = "%int32_to_int"
 external of_float : float -> int32
   = "caml_int32_of_float" "caml_int32_of_float_unboxed"
   [@@unboxed] [@@noalloc]

stdlib/int32.mli

@@ -128,7 +128,7 @@ external of_int : int -> (int32[@local_opt]) = "%int32_of_int"
     (type [int32]). On 64-bit platforms, the argument is taken
     modulo 2{^32}. *)
 
-external to_int : int32 -> int = "%int32_to_int"
+external to_int : (int32[@local_opt]) -> int = "%int32_to_int"
 (** Convert the given 32-bit integer (type [int32]) to an
    integer (type [int]).  On 32-bit platforms, the 32-bit integer
    is taken modulo 2{^31}, i.e. the high-order bit is lost

stdlib/int64.ml

@@ -28,7 +28,7 @@ external shift_left : (int64[@local_opt]) -> int -> (int64[@local_opt]) = "%int6
 external shift_right : (int64[@local_opt]) -> int -> (int64[@local_opt]) = "%int64_asr"
 external shift_right_logical : (int64[@local_opt]) -> int -> (int64[@local_opt]) = "%int64_lsr"
 external of_int : int -> (int64[@local_opt]) = "%int64_of_int"
-external to_int : int64 -> int = "%int64_to_int"
+external to_int : (int64[@local_opt]) -> int = "%int64_to_int"
 external of_float : float -> int64
   = "caml_int64_of_float" "caml_int64_of_float_unboxed"
   [@@unboxed] [@@noalloc]

stdlib/int64.mli

@@ -126,7 +126,7 @@ external of_int : int -> (int64[@local_opt]) = "%int64_of_int"
 (** Convert the given integer (type [int]) to a 64-bit integer
     (type [int64]). *)
 
-external to_int : int64 -> int = "%int64_to_int"
+external to_int : (int64[@local_opt]) -> int = "%int64_to_int"
 (** Convert the given 64-bit integer (type [int64]) to an
    integer (type [int]).  On 64-bit platforms, the 64-bit integer
    is taken modulo 2{^63}, i.e. the high-order bit is lost

stdlib/nativeint.ml

@@ -28,7 +28,7 @@ external shift_left: (nativeint[@local_opt]) -> int -> (nativeint[@local_opt]) =
 external shift_right: (nativeint[@local_opt]) -> int -> (nativeint[@local_opt]) = "%nativeint_asr"
 external shift_right_logical: (nativeint[@local_opt]) -> int -> (nativeint[@local_opt]) = "%nativeint_lsr"
 external of_int: int -> (nativeint[@local_opt]) = "%nativeint_of_int"
-external to_int: nativeint -> int = "%nativeint_to_int"
+external to_int: (nativeint[@local_opt]) -> int = "%nativeint_to_int"
 external of_float : float -> nativeint
   = "caml_nativeint_of_float" "caml_nativeint_of_float_unboxed"
   [@@unboxed] [@@noalloc]

stdlib/nativeint.mli

@@ -147,7 +147,7 @@ external of_int : int -> (nativeint[@local_opt]) = "%nativeint_of_int"
 (** Convert the given integer (type [int]) to a native integer
    (type [nativeint]). *)
 
-external to_int : nativeint -> int = "%nativeint_to_int"
+external to_int : (nativeint[@local_opt]) -> int = "%nativeint_to_int"
 (** Convert the given native integer (type [nativeint]) to an
    integer (type [int]).  The high-order bit is lost during
    the conversion. *)

testsuite/tests/typing-local/local.ml

@@ -1713,6 +1713,12 @@ let intf (local_ x) = x |> Int.succ |> Int.add 42 |> pred |> (/) 100 |> (+) 1
 val intf : local_ int -> int = <fun>
 |}]
 
+(* primitives don't count as tail calls, so you can pass them locals *)
+let primloc x = let local_ y = Int32.add x 1l in Int32.to_int y
+[%%expect{|
+val primloc : int32 -> int = <fun>
+|}]
+
 (* mode-crossing using unary + *)
 let promote (local_ x) = +x
 [%%expect{|

typing/typecore.ml

@@ -5214,7 +5214,13 @@ and type_application env app_loc expected_mode funct funct_mode sargs =
         collect_apply_args env funct ignore_labels ty (instance ty)
           (Value_mode.regional_to_global_alloc funct_mode) sargs
       in
-      let position = expected_mode.position in
+      let position =
+        match funct.exp_desc with
+        | Texp_ident (_, _, _, Id_prim _) ->
+           (* Primitives cannot be tail-called, so their arguments
+              need not be mode-restricted *)
+           Nontail
+        | _ -> expected_mode.position in
       let partial_app = is_partial_apply args in
       let args =
         List.map