Add support for immediate attribute

Changes

@@ -63,6 +63,9 @@ Language features:
 * GPR#234: allow "[]" as a user-defined constructor. Demand parenthesis
   around "::" when using "::" as user-defined constructor.
   (Runhang Li, review by Damien Doligez)
+- GPR#188: accept [@@immediate] attribute on type declarations to mark types
+  that are represented at runtime by an integer
+  (Will Crichton, reviewed by Leo White)
 
 Compilers:
 - PR#4080, PR#6537, PR#5333: fix stack overflow in the compiler when -pack'ing

bytecomp/typeopt.ml

@@ -33,35 +33,11 @@ let is_base_type env ty base_ty_path =
 let has_base_type exp base_ty_path =
   is_base_type exp.exp_env exp.exp_type base_ty_path
 
-let maybe_pointer_type env typ =
-  let maybe_pointer =
-    match scrape env typ with
-    | Tconstr(p, args, abbrev) ->
-        not (Path.same p Predef.path_int) &&
-        not (Path.same p Predef.path_char) &&
-        begin try
-          match Env.find_type p env with
-          | {type_kind = Type_variant []} -> true (* type exn *)
-          | {type_kind = Type_variant cstrs} ->
-              List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs
-          | _ -> true
-        with Not_found -> true
-          (* This can happen due to e.g. missing -I options,
-             causing some .cmi files to be unavailable.
-             Maybe we should emit a warning. *)
-        end
-    | Tvariant row ->
-        let row = Btype.row_repr row in
-        (* if all labels are devoid of arguments, not a pointer *)
-        not row.row_closed
-        || List.exists
-            (function
-              | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
-              | _ -> false)
-            row.row_fields
-    | _ -> true
-  in
-  if maybe_pointer then Pointer else Immediate
+let maybe_pointer_type env ty =
+  if Ctype.maybe_pointer_type env ty then
+    Pointer
+  else
+    Immediate
 
 let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
 

bytecomp/typeopt.mli

@@ -26,3 +26,4 @@ val array_kind : Typedtree.expression -> Lambda.array_kind
 val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
 val bigarray_type_kind_and_layout :
       Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
+

testsuite/tests/typing-immediate/Makefile

@@ -0,0 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/typing-immediate/immediate.ml

@@ -0,0 +1,86 @@
+module type S = sig type t [@@immediate] end;;
+module F (M : S) : S = M;;
+
+(* VALID DECLARATIONS *)
+
+module A = struct
+  (* Abstract types can be immediate *)
+  type t [@@immediate]
+
+  (* [@@immediate] tag here is unnecessary but valid since t has it *)
+  type s = t [@@immediate]
+
+  (* Again, valid alias even without tag *)
+  type r = s
+
+  (* Mutually recursive declarations work as well *)
+  type p = q [@@immediate]
+  and q = int
+end;;
+
+(* Valid using with constraints *)
+module type X = sig type t end;;
+module Y = struct type t = int end;;
+module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
+
+(* Valid using an explicit signature *)
+module M_valid : S = struct type t = int end;;
+module FM_valid = F (struct type t = int end);;
+
+(* Practical usage over modules *)
+module Foo : sig type t val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+
+module Bar : sig type t [@@immediate] val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+
+let test f =
+  let start = Sys.time() in f ();
+  (Sys.time() -. start);;
+
+let test_foo () =
+  for i = 0 to 100_000_000 do
+    Foo.x := !Foo.x
+  done;;
+
+let test_bar () =
+  for i = 0 to 100_000_000 do
+    Bar.x := !Bar.x
+  done;;
+
+(* Uncomment these to test. Should see substantial speedup!
+let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
+let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
+
+
+(* INVALID DECLARATIONS *)
+
+(* Cannot directly declare a non-immediate type as immediate *)
+module B = struct
+  type t = string [@@immediate]
+end;;
+
+(* Not guaranteed that t is immediate, so this is an invalid declaration *)
+module C = struct
+  type t
+  type s = t [@@immediate]
+end;;
+
+(* Can't ascribe to an immediate type signature with a non-immediate type *)
+module D : sig type t [@@immediate] end = struct
+  type t = string
+end;;
+
+(* Same as above but with explicit signature *)
+module M_invalid : S = struct type t = string end;;
+module FM_invalid = F (struct type t = string end);;
+
+(* Can't use a non-immediate type even if mutually recursive *)
+module E = struct
+  type t = s [@@immediate]
+  and s = string
+end;;

testsuite/tests/typing-immediate/immediate.ml.reference

@@ -0,0 +1,71 @@
+
+# module type S = sig type t [@@immediate] end
+# module F : functor (M : S) -> S
+#                                 module A :
+  sig
+    type t [@@immediate]
+    type s = t [@@immediate]
+    type r = s
+    type p = q [@@immediate]
+    and q = int
+  end
+#     module type X = sig type t end
+# module Y : sig type t = int end
+# module Z : sig type t [@@immediate] end
+#     module M_valid : S
+# module FM_valid : S
+#           module Foo : sig type t val x : t ref end
+#         module Bar : sig type t [@@immediate] val x : t ref end
+#       val test : (unit -> 'a) -> float = <fun>
+#         val test_foo : unit -> unit = <fun>
+#         val test_bar : unit -> unit = <fun>
+#   * *                 Characters 306-335:
+    type t = string [@@immediate]
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+#           Characters 106-130:
+    type s = t [@@immediate]
+    ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+#         Characters 120-148:
+  ..........................................struct
+    type t = string
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = string end
+       is not included in
+         sig type t [@@immediate] end
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+#     Characters 72-98:
+  module M_invalid : S = struct type t = string end;;
+                         ^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+       Modules do not match: sig type t = string end is not included in S
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+# Characters 23-49:
+  module FM_invalid = F (struct type t = string end);;
+                         ^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+       Modules do not match: sig type t = string end is not included in S
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+#           Characters 85-109:
+    type t = s [@@immediate]
+    ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+# 

typing/ctype.ml

@@ -1100,6 +1100,7 @@ let new_declaration newtype manifest =
     type_newtype_level = newtype;
     type_loc = Location.none;
     type_attributes = [];
+    type_immediate = false;
   }
 
 let instance_constructor ?in_pattern cstr =
@@ -4314,6 +4315,7 @@ let nondep_type_decl env mid id is_covariant decl =
       type_newtype_level = None;
       type_loc = decl.type_loc;
       type_attributes = decl.type_attributes;
+      type_immediate = decl.type_immediate;
     }
   with Not_found ->
     clear_hash ();
@@ -4444,3 +4446,25 @@ let same_constr env t1 t2 =
 
 let () =
   Env.same_constr := same_constr
+
+let maybe_pointer_type env typ =
+   match (repr typ).desc with
+  | Tconstr(p, args, abbrev) ->
+    begin try
+      let type_decl = Env.find_type p env in
+      not type_decl.type_immediate
+    with Not_found -> true
+    (* This can happen due to e.g. missing -I options,
+       causing some .cmi files to be unavailable.
+       Maybe we should emit a warning. *)
+    end
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      (* if all labels are devoid of arguments, not a pointer *)
+      not row.row_closed
+      || List.exists
+          (function
+            | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
+            | _ -> false)
+          row.row_fields
+  | _ -> true

typing/ctype.mli

@@ -278,6 +278,9 @@ val get_current_level: unit -> int
 val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
 val reset_reified_var_counter: unit -> unit
 
+val maybe_pointer_type : Env.t -> type_expr -> bool
+        (* True if type is possibly pointer, false if definitely not a pointer *)
+
 (* Stubs *)
 val package_subtype :
     (Env.t -> Path.t -> Longident.t list -> type_expr list ->

typing/datarepr.ml

@@ -76,6 +76,7 @@ let constructor_args cd_args cd_res path rep =
           type_newtype_level = None;
           type_loc = Location.none;
           type_attributes = [];
+          type_immediate = false;
         }
       in
       existentials,

typing/includecore.ml

@@ -124,6 +124,7 @@ type type_mismatch =
   | Field_names of int * Ident.t * Ident.t
   | Field_missing of bool * Ident.t
   | Record_representation of bool
+  | Immediate
 
 let report_type_mismatch0 first second decl ppf err =
   let pr fmt = Format.fprintf ppf fmt in
@@ -150,6 +151,7 @@ let report_type_mismatch0 first second decl ppf err =
       pr "Their internal representations differ:@ %s %s %s"
         (if b then second else first) decl
         "uses unboxed float representation"
+  | Immediate -> pr "%s is not an immediate type" first
 
 let report_type_mismatch first second decl ppf =
   List.iter
@@ -254,9 +256,18 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
     | (_, _) -> [Kind]
   in
   if err <> [] then err else
-  let abstr =
-    decl2.type_private = Private ||
-    decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+  let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+  (* If attempt to assign a non-immediate type (e.g. string) to a type that
+   * must be immediate, then we error *)
+  let err =
+    if abstr &&
+       not decl1.type_immediate &&
+       decl2.type_immediate then
+      [Immediate]
+    else []
+  in
+  if err <> [] then err else
+  let abstr = abstr || decl2.type_private = Private in
   let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
   let constrained ty = not (Btype.(is_Tvar (repr ty))) in
   if List.for_all2

typing/includecore.mli

@@ -30,6 +30,7 @@ type type_mismatch =
   | Field_names of int * Ident.t * Ident.t
   | Field_missing of bool * Ident.t
   | Record_representation of bool
+  | Immediate
 
 val value_descriptions:
     Env.t -> value_description -> value_description -> module_coercion

typing/oprint.ml

@@ -500,6 +500,9 @@ and print_out_type_decl kwd ppf td =
     Asttypes.Private -> fprintf ppf " private"
   | Asttypes.Public -> ()
   in
+  let print_immediate ppf =
+    if td.otype_immediate then fprintf ppf " [%@%@immediate]" else ()
+  in
   let print_out_tkind ppf = function
   | Otyp_abstract -> ()
   | Otyp_record lbls ->
@@ -517,10 +520,11 @@ and print_out_type_decl kwd ppf td =
         print_private td.otype_private
         !out_type ty
   in
-  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t@]"
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t@]"
     print_name_params
     print_out_tkind ty
     print_constraints
+    print_immediate
 
 and print_out_constr ppf (name, tyl,ret_type_opt) =
   match ret_type_opt with

typing/outcometree.mli

@@ -102,6 +102,7 @@ and out_type_decl =
     otype_params: (string * (bool * bool)) list;
     otype_type: out_type;
     otype_private: Asttypes.private_flag;
+    otype_immediate: bool;
     otype_cstrs: (out_type * out_type) list }
 and out_extension_constructor =
   { oext_name: string;

typing/predef.ml

@@ -120,8 +120,11 @@ let decl_abstr =
    type_variance = [];
    type_newtype_level = None;
    type_attributes = [];
+   type_immediate = false;
   }
 
+let decl_abstr_imm = {decl_abstr with type_immediate = true}
+
 let cstr id args =
   {
     cd_id = id;
@@ -141,10 +144,12 @@ and ident_some = ident_create "Some"
 let common_initial_env add_type add_extension empty_env =
   let decl_bool =
     {decl_abstr with
-     type_kind = Type_variant([cstr ident_false []; cstr ident_true []])}
+     type_kind = Type_variant([cstr ident_false []; cstr ident_true []]);
+     type_immediate = true}
   and decl_unit =
     {decl_abstr with
-     type_kind = Type_variant([cstr ident_void []])}
+     type_kind = Type_variant([cstr ident_void []]);
+     type_immediate = true}
   and decl_exn =
     {decl_abstr with
      type_kind = Type_open}
@@ -214,8 +219,8 @@ let common_initial_env add_type add_extension empty_env =
   add_type ident_bool decl_bool (
   add_type ident_float decl_abstr (
   add_type ident_string decl_abstr (
-  add_type ident_char decl_abstr (
-  add_type ident_int decl_abstr (
+  add_type ident_char decl_abstr_imm (
+  add_type ident_int decl_abstr_imm (
   add_type ident_extension_constructor decl_abstr (
     empty_env)))))))))))))))))))))))))))
 

typing/printtyp.ml

@@ -1,3 +1,4 @@
+
 (***********************************************************************)
 (*                                                                     *)
 (*                                OCaml                                *)
@@ -863,11 +864,15 @@ let rec tree_of_type_decl id decl =
     | Type_open ->
         tree_of_manifest Otyp_open,
         Public
+  in
+  let immediate =
+    List.exists (fun (loc, _) -> loc.txt = "immediate") decl.type_attributes
   in
     { otype_name = name;
       otype_params = args;
       otype_type = ty;
       otype_private = priv;
+      otype_immediate = immediate;
       otype_cstrs = constraints }
 
 and tree_of_constructor_arguments = function
@@ -1161,6 +1166,7 @@ let dummy =
     type_private = Public; type_manifest = None; type_variance = [];
     type_newtype_level = None; type_loc = Location.none;
     type_attributes = [];
+    type_immediate = false;
   }
 
 let hide_rec_items = function

typing/subst.ml

@@ -250,6 +250,7 @@ let type_declaration s decl =
       type_newtype_level = None;
       type_loc = loc s decl.type_loc;
       type_attributes = attrs s decl.type_attributes;
+      type_immediate = decl.type_immediate;
     }
   in
   cleanup_types ();

typing/typeclass.ml

@@ -1213,6 +1213,7 @@ let temp_abbrev loc env id arity =
        type_newtype_level = None;
        type_loc = loc;
        type_attributes = []; (* or keep attrs from the class decl? *)
+       type_immediate = false;
       }
       env
   in
@@ -1459,6 +1460,7 @@ let class_infos define_class kind
      type_newtype_level = None;
      type_loc = cl.pci_loc;
      type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = false;
     }
   in
   let (cl_params, cl_ty) =
@@ -1476,6 +1478,7 @@ let class_infos define_class kind
      type_newtype_level = None;
      type_loc = cl.pci_loc;
      type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = false;
     }
   in
   ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,

typing/typecore.ml

@@ -2820,6 +2820,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         type_newtype_level = Some (level, level);
         type_loc = loc;
         type_attributes = [];
+        type_immediate = false;
       }
       in
       Ident.set_current_time ty.level;

typing/typedecl.ml

@@ -51,6 +51,7 @@ type error =
   | Multiple_native_repr_attributes
   | Cannot_unbox_or_untag_type of native_repr_kind
   | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Bad_immediate_attribute
 
 open Typedtree
 
@@ -72,6 +73,7 @@ let enter_type env sdecl id =
       type_newtype_level = None;
       type_loc = sdecl.ptype_loc;
       type_attributes = sdecl.ptype_attributes;
+      type_immediate = false;
     }
   in
   Env.add_type ~check:true id decl env
@@ -301,6 +303,7 @@ let transl_declaration env sdecl id =
         type_newtype_level = None;
         type_loc = sdecl.ptype_loc;
         type_attributes = sdecl.ptype_attributes;
+        type_immediate = false;
       } in
 
   (* Check constraints *)
@@ -879,11 +882,28 @@ let is_sharp id =
   let s = Ident.name id in
   String.length s > 0 && s.[0] = '#'
 
-let rec compute_variance_fixpoint env decls required variances =
+let marked_as_immediate decl =
+  List.exists
+    (fun (loc, _) -> loc.txt = "immediate")
+    decl.type_attributes
+
+let compute_immediacy env tdecl =
+  match (tdecl.type_kind, tdecl.type_manifest) with
+  | (Type_variant (_ :: _ as cstrs), _) ->
+    not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
+  | (Type_abstract, Some(typ)) ->
+    not (Ctype.maybe_pointer_type env typ)
+  | (Type_abstract, None) -> marked_as_immediate tdecl
+  | _ -> false
+
+(* Computes the fixpoint for the variance and immediacy of type declarations *)
+
+let rec compute_properties_fixpoint env decls required variances immediacies =
   let new_decls =
     List.map2
-      (fun (id, decl) variance -> id, {decl with type_variance = variance})
-      decls variances
+      (fun (id, decl) (variance, immediacy) ->
+         id, {decl with type_variance = variance; type_immediate = immediacy})
+      decls (List.combine variances immediacies)
   in
   let new_env =
     List.fold_right
@@ -897,8 +917,13 @@ let rec compute_variance_fixpoint env decls required variances =
   in
   let new_variances =
     List.map2 (List.map2 Variance.union) new_variances variances in
-  if new_variances <> variances then
-    compute_variance_fixpoint env decls required new_variances
+  let new_immediacies =
+    List.map
+      (fun (id, decl) -> compute_immediacy new_env decl)
+      new_decls
+  in
+  if new_variances <> variances || new_immediacies <> immediacies then
+    compute_properties_fixpoint env decls required new_variances new_immediacies
   else begin
     (* List.iter (fun (id, decl) ->
       Printf.eprintf "%s:" (Ident.name id);
@@ -907,6 +932,11 @@ let rec compute_variance_fixpoint env decls required variances =
         decl.type_variance;
       prerr_endline "")
       new_decls; *)
+    List.iter (fun (_, decl) ->
+      if (marked_as_immediate decl) && (not decl.type_immediate) then
+        raise (Error (decl.type_loc, Bad_immediate_attribute))
+      else ())
+      new_decls;
     List.iter2
       (fun (id, decl) req -> if not (is_sharp id) then
         ignore (compute_variance_decl new_env true decl req))
@@ -935,8 +965,11 @@ let compute_variance_decls env cldecls =
         (add_injectivity variance, ci.ci_loc) :: req)
       cldecls ([],[])
   in
-  let variances = List.map init_variance decls in
-  let (decls, _) = compute_variance_fixpoint env decls required variances in
+  let (decls, _) =
+    compute_properties_fixpoint env decls required
+      (List.map init_variance decls)
+      (List.map (fun _ -> false) decls)
+  in
   List.map2
     (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
       let variance = decl.type_variance in
@@ -1117,7 +1150,9 @@ let transl_type_decl env rec_flag sdecl_list =
       sdecl_list
   in
   let final_decls, final_env =
-    compute_variance_fixpoint env decls required (List.map init_variance decls)
+    compute_properties_fixpoint env decls required
+      (List.map init_variance decls)
+      (List.map (fun _ -> false) decls)
   in
   (* Check re-exportation *)
   List.iter2 (check_abbrev final_env) sdecl_list final_decls;
@@ -1541,6 +1576,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
       type_newtype_level = None;
       type_loc = sdecl.ptype_loc;
       type_attributes = sdecl.ptype_attributes;
+      type_immediate = false;
     }
   in
   begin match row_path with None -> ()
@@ -1550,10 +1586,12 @@ let transl_with_constraint env id row_path orig_decl sdecl =
   | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
   end;
   let decl = name_recursion sdecl id decl in
-  let decl =
-    {decl with type_variance =
-     compute_variance_decl env true decl
-       (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)} in
+  let type_variance =
+    compute_variance_decl env true decl
+      (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)
+  in
+  let type_immediate = compute_immediacy env decl in
+  let decl = {decl with type_variance; type_immediate} in
   Ctype.end_def();
   generalize_decl decl;
   {
@@ -1585,6 +1623,7 @@ let abstract_type_decl arity =
       type_newtype_level = None;
       type_loc = Location.none;
       type_attributes = [];
+      type_immediate = false;
      } in
   Ctype.end_def();
   generalize_decl decl;
@@ -1826,6 +1865,10 @@ let report_error ppf = function
         "The attribute '%s' should be attached to a direct argument or \
          result of the primitive, it should not occur deeply into its type"
         (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
+  | Bad_immediate_attribute ->
+      fprintf ppf "@[%s@ %s@]"
+        "Types marked with the immediate attribute must be"
+        "non-pointer types like int or bool"
 
 let () =
   Location.register_error_of_exn

typing/typedecl.mli

@@ -88,6 +88,7 @@ type error =
   | Multiple_native_repr_attributes
   | Cannot_unbox_or_untag_type of native_repr_kind
   | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Bad_immediate_attribute
 
 exception Error of Location.t * error
 

typing/typemod.ml

@@ -177,6 +177,7 @@ let merge_constraint initial_env loc sg constr =
             type_loc = sdecl.ptype_loc;
             type_newtype_level = None;
             type_attributes = [];
+            type_immediate = false;
           }
         and id_row = Ident.create (s^"#row") in
         let initial_env =

typing/types.ml

@@ -145,6 +145,7 @@ type type_declaration =
     type_newtype_level: (int * int) option;
     type_loc: Location.t;
     type_attributes: Parsetree.attributes;
+    type_immediate: bool;
  }
 
 and type_kind =

typing/types.mli

@@ -290,6 +290,7 @@ type type_declaration =
     (* definition level * expansion level *)
     type_loc: Location.t;
     type_attributes: Parsetree.attributes;
+    type_immediate: bool; (* true iff type should not be a pointer *)
   }
 
 and type_kind =