Changement representation des primitives.

Introduction de datarepr.


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@146 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

14 files changed, 152 insertions, 102 deletions

diff --git a/typing/ctype.ml b/typing/ctype.ml
index 60fb7a415..cbebe7f2a 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -342,3 +342,4 @@ let rec arity ty =
   | _ -> 0
 
 let none = Ttuple []                  (* Clearly ill-formed type *)
+
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
new file mode 100644
index 000000000..ab61b0fb9
--- /dev/null
+++ b/typing/datarepr.ml
@@ -0,0 +1,58 @@
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Misc
+open Asttypes
+open Typedtree
+
+let constructor_descrs ty_res cstrs =
+  let num_consts = ref 0 and num_nonconsts = ref 0 in
+  List.iter
+    (function (name, []) -> incr num_consts
+            | (name, _)  -> incr num_nonconsts)
+    cstrs;
+  let rec describe_constructors idx_const idx_nonconst = function
+      [] -> []
+    | (name, ty_args) :: rem ->
+        let (tag, descr_rem) =
+          match ty_args with
+            [] -> (Cstr_constant idx_const,
+                   describe_constructors (idx_const+1) idx_nonconst rem)
+          | _  -> (Cstr_block idx_nonconst,
+                   describe_constructors idx_const (idx_nonconst+1) rem) in
+        let cstr =
+          { cstr_res = ty_res;
+            cstr_args = ty_args;
+            cstr_arity = List.length ty_args;
+            cstr_tag = tag;
+            cstr_consts = !num_consts;
+            cstr_nonconsts = !num_nonconsts } in
+        (name, cstr) :: descr_rem in
+  describe_constructors 0 0 cstrs
+
+let exception_descr path_exc decl =
+  { cstr_res = Predef.type_exn;
+    cstr_args = decl;
+    cstr_arity = List.length decl;
+    cstr_tag = Cstr_exception path_exc;
+    cstr_consts = -1;
+    cstr_nonconsts = -1 }
+
+let dummy_label =
+  { lbl_res = Ttuple []; lbl_arg = Ttuple []; lbl_mut = Immutable;
+    lbl_pos = (-1); lbl_all = [||] }
+
+let label_descrs ty_res lbls =
+  let all_labels = Array.new (List.length lbls) dummy_label in
+  let rec describe_labels num = function
+      [] -> []
+    | (name, mut_flag, ty_arg) :: rest ->
+        let lbl =
+          { lbl_res = ty_res;
+            lbl_arg = ty_arg;
+            lbl_mut = mut_flag;
+            lbl_pos = num;
+            lbl_all = all_labels } in
+        all_labels.(num) <- lbl;
+        (name, lbl) :: describe_labels (num+1) rest in
+  describe_labels 0 lbls
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
new file mode 100644
index 000000000..ee8bebade
--- /dev/null
+++ b/typing/datarepr.mli
@@ -0,0 +1,14 @@
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Asttypes
+open Typedtree
+
+val constructor_descrs:
+  type_expr -> (string * type_expr list) list ->
+    (string * constructor_description) list
+val exception_descr:
+  Path.t -> type_expr list -> constructor_description
+val label_descrs:
+  type_expr -> (string * mutable_flag * type_expr) list ->
+    (string * label_description) list
diff --git a/typing/env.ml b/typing/env.ml
index 3418a4f92..b970a235f 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -196,65 +196,15 @@ let rec scrape_modtype mty env =
 let constructors_of_type ty_path decl =
   match decl.type_kind with
     Type_variant cstrs ->
-      let ty_res = Tconstr(ty_path, decl.type_params) in
-      let num_consts = ref 0 and num_nonconsts = ref 0 in
-      List.iter
-        (function (name, []) -> incr num_consts
-                | (name, _)  -> incr num_nonconsts)
-        cstrs;
-      let rec describe_constructors idx_const idx_nonconst = function
-          [] -> []
-        | (name, ty_args) :: rem ->
-            let (tag, descr_rem) =
-              match ty_args with
-                [] -> (Cstr_constant idx_const,
-                       describe_constructors (idx_const+1) idx_nonconst rem)
-              | _  -> (Cstr_block idx_nonconst,
-                       describe_constructors idx_const (idx_nonconst+1) rem) in
-            let cstr =
-              { cstr_res = ty_res;
-                cstr_args = ty_args;
-                cstr_arity = List.length ty_args;
-                cstr_tag = tag;
-                cstr_consts = !num_consts;
-                cstr_nonconsts = !num_nonconsts } in
-            (name, cstr) :: descr_rem in
-      describe_constructors 0 0 cstrs
+      Datarepr.constructor_descrs (Tconstr(ty_path, decl.type_params)) cstrs
   | _ -> []
 
-(* Compute a constructor description for an exception *)
-
-let constructor_exception path_exc decl =
-  { cstr_res = Predef.type_exn;
-    cstr_args = decl;
-    cstr_arity = List.length decl;
-    cstr_tag = Cstr_exception path_exc;
-    cstr_consts = -1;
-    cstr_nonconsts = -1 }
-
 (* Compute label descriptions *)
 
-let dummy_label =
-  { lbl_res = Ttuple []; lbl_arg = Ttuple []; lbl_mut = Immutable;
-    lbl_pos = (-1); lbl_all = [||] }
-
 let labels_of_type ty_path decl =
   match decl.type_kind with
     Type_record labels ->
-      let ty_res = Tconstr(ty_path, decl.type_params) in
-      let all_labels = Array.new (List.length labels) dummy_label in
-      let rec describe_labels num = function
-          [] -> []
-        | (name, mut_flag, ty_arg) :: rest ->
-            let lbl =
-              { lbl_res = ty_res;
-                lbl_arg = ty_arg;
-                lbl_mut = mut_flag;
-                lbl_pos = num;
-                lbl_all = all_labels } in
-            all_labels.(num) <- lbl;
-            (name, lbl) :: describe_labels (num+1) rest in
-      describe_labels 0 labels
+      Datarepr.label_descrs (Tconstr(ty_path, decl.type_params)) labels
   | _ -> []
 
 (* Given a signature and a root path, prefix all idents in the signature
@@ -321,7 +271,7 @@ let rec components_of_module env path mty =
               (labels_of_type path decl')
         | Tsig_exception(id, decl) ->
             let decl' = Subst.exception_declaration sub decl in
-            let cstr = constructor_exception path decl' in
+            let cstr = Datarepr.exception_descr path decl' in
             c.comp_constrs <-
               Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
             incr pos
@@ -376,7 +326,7 @@ and store_type id path info env =
 
 and store_exception id path decl env =
   { values = env.values;
-    constrs = Ident.add id (constructor_exception path decl) env.constrs;
+    constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;
     labels = env.labels;
     types = env.types;
     modules = env.modules;
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 781abf166..4e06cccef 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -10,8 +10,8 @@ open Typedtree
 let value_descriptions env vd1 vd2 =
   Ctype.moregeneral env vd1.val_type vd2.val_type &
   begin match (vd1.val_prim, vd2.val_prim) with
-      (Primitive(p1, ar1), Primitive(p2, ar2)) -> p1 = p2 & ar1 = ar2
-    | (Not_prim, Primitive(p, ar)) -> false
+      (Some p1, Some p2) -> p1 = p2
+    | (None, Some p) -> false
     | _ -> true
   end
 
diff --git a/typing/predef.ml b/typing/predef.ml
index fdc3d82ee..4a471d912 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -26,13 +26,13 @@ and path_array = Pident ident_array
 and path_list = Pident ident_list
 and path_format = Pident ident_format
 
-let type_int = Tconstr(Pident ident_int, [])
-and type_char = Tconstr(Pident ident_char, [])
-and type_string = Tconstr(Pident ident_string, [])
-and type_float = Tconstr(Pident ident_float, [])
-and type_bool = Tconstr(Pident ident_bool, [])
-and type_unit = Tconstr(Pident ident_unit, [])
-and type_exn = Tconstr(Pident ident_exn, [])
+let type_int = Tconstr(path_int, [])
+and type_char = Tconstr(path_char, [])
+and type_string = Tconstr(path_string, [])
+and type_float = Tconstr(path_float, [])
+and type_bool = Tconstr(path_bool, [])
+and type_unit = Tconstr(path_unit, [])
+and type_exn = Tconstr(path_exn, [])
 and type_array t = Tconstr(path_array, [t])
 and type_list t = Tconstr(path_list, [t])
 
@@ -49,27 +49,40 @@ let path_match_failure = Pident ident_match_failure
 
 let build_initial_env add_type add_exception empty_env =
   let newvar() =
-    (* Cannot call newvar here because ctype imports predef via env *)
+    (* Cannot call the real newvar from ctype here
+       because ctype imports predef via env *)
     Tvar{tvar_level = -1 (*generic_level*); tvar_link = None} in
   let decl_abstr =
-    {type_params = []; type_arity = 0; type_kind = Type_abstract}
+    {type_params = [];
+     type_arity = 0;
+     type_kind = Type_abstract}
   and decl_bool =
-    {type_params = []; type_arity = 0;
+    {type_params = [];
+     type_arity = 0;
      type_kind = Type_variant["false",[]; "true",[]]}
   and decl_unit =
-    {type_params = []; type_arity = 0; type_kind = Type_variant["()",[]]}
+    {type_params = []; 
+     type_arity = 0;
+     type_kind = Type_variant["()",[]]}
   and decl_exn =
-    {type_params = []; type_arity = 0; type_kind = Type_variant[]}
+    {type_params = [];
+     type_arity = 0;
+     type_kind = Type_variant []}
   and decl_array =
     let tvar = newvar() in
-    {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract}
+    {type_params = [tvar];
+     type_arity = 1;
+     type_kind = Type_abstract}
   and decl_list =
     let tvar = newvar() in
-    {type_params = [tvar]; type_arity = 1;
+    {type_params = [tvar];
+     type_arity = 1;
      type_kind = Type_variant["[]", []; "::", [tvar; type_list tvar]]}
   and decl_format =
-    {type_params = [newvar(); newvar(); newvar()]; type_arity = 3;
+    {type_params = [newvar(); newvar(); newvar()];
+     type_arity = 3;
      type_kind = Type_abstract} in
+
   add_exception ident_match_failure [Ttuple[type_string; type_int; type_int]] (
   add_exception ident_out_of_memory [] (
   add_exception ident_invalid_argument [type_string] (
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 3b99e70e3..1191b5b6b 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -145,16 +145,20 @@ let exception_declaration id decl =
 
 (* Print a value declaration *)
 
+let primitive_description p =
+  print_string "\""; print_string p.prim_name; print_string "\"";
+  if not p.prim_alloc then print_string " \"noalloc\""
+
 let value_description id decl =
   open_hovbox 2;
   begin match decl.val_prim with
-    Not_prim ->
+    None ->
       print_string "val "; ident id; print_string " :"; print_space();
       type_scheme decl.val_type
-  | Primitive(p, ar) ->
+  | Some p ->
       print_string "val "; ident id; print_string " :"; print_space();
       type_scheme decl.val_type; print_space();
-      print_string "= \""; print_string p; print_string "\""
+      print_string "= "; primitive_description p
   end;
   close_box()
 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 860d361a5..45763cc4a 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -139,7 +139,7 @@ let add_pattern_variables env =
   pattern_variables := [];
   List.fold_right
     (fun (id, ty) env ->
-      Env.add_value id {val_type = ty; val_prim = Not_prim} env)
+      Env.add_value id {val_type = ty; val_prim = None} env)
     pv env
 
 let type_pattern env spat =
@@ -408,7 +408,7 @@ let rec type_exp env sexp =
       let high = type_expect env shigh Predef.type_int in
       let (id, new_env) =
         Env.enter_value param {val_type = Predef.type_int;
-                                val_prim = Not_prim} env in
+                                val_prim = None} env in
       let body = type_statement new_env sbody in
       { exp_desc = Texp_for(id, low, high, dir, body);
         exp_loc = sexp.pexp_loc;
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 56fa562c6..05575fc0a 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -9,7 +9,7 @@ val type_binding:
             (Typedtree.pattern * Typedtree.expression) list * Env.t
 val type_expression:
         Env.t -> Parsetree.expression -> Typedtree.expression
-
+        
 type error =
     Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 453bd6ecc..d7272e250 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -78,8 +78,9 @@ let transl_declaration env (name, sdecl) id =
           lbls) in
   Ctype.end_def();
   List.iter Ctype.generalize params;
-  (id,
-   {type_params = params; type_arity = List.length params; type_kind = kind})
+  (id, {type_params = params;
+        type_arity = List.length params;
+        type_kind = kind })
 
 (* Check for recursive abbrevs *)
 
@@ -111,6 +112,20 @@ let transl_exception env excdecl =
   reset_type_variables();
   List.map (transl_simple_type env true) excdecl
 
+(* Translate a value declaration *)
+
+let transl_value_decl env valdecl =
+  let ty = Typetexp.transl_type_scheme env valdecl.pval_type in
+  let arity = Ctype.arity ty in
+  let prim =
+    match valdecl.pval_prim with
+      name :: "noalloc" :: _ ->
+        Some { prim_name = name; prim_arity = arity; prim_alloc = false }
+    | name :: _ -> 
+        Some { prim_name = name; prim_arity = arity; prim_alloc = true }
+    | [] -> None in
+  { val_type = ty; val_prim = prim }
+
 (* Error report *)
 
 open Format
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 2507e6fc8..c31fe8e90 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -1,4 +1,4 @@
-(* Typing of type definitions *)
+(* Typing of type definitions and primitive definitions *)
 
 open Typedtree
 
@@ -8,6 +8,9 @@ val transl_type_decl:
 val transl_exception:
         Env.t -> Parsetree.exception_declaration -> exception_declaration
 
+val transl_value_decl:
+        Env.t -> Parsetree.value_description -> value_description
+    
 type error =
     Repeated_parameter
   | Duplicate_constructor of string
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 2f170a1c6..9860ff5f8 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -18,11 +18,12 @@ and type_variable =
 (* Value descriptions *)
 
 type value_description =
-  { val_type: type_expr;                (* Type of the value *)
-    val_prim: primitive_description }   (* Is this a primitive? *)
+  { val_type: type_expr;                       (* Type of the val *)
+    val_prim: primitive_description option }   (* Is this a primitive? *)
 and primitive_description =
-    Not_prim
-  | Primitive of string * int
+  { prim_name: string;
+    prim_arity: int;
+    prim_alloc: bool }
 
 (* Constructor descriptions *)
 
@@ -46,7 +47,7 @@ type label_description =
     lbl_arg: type_expr;                 (* Type of the argument *)
     lbl_mut: mutable_flag;              (* Is this a mutable field? *)
     lbl_pos: int;                       (* Position in block *)
-    lbl_all: label_description array     (* All the labels in this type *)
+    lbl_all: label_description array    (* All the labels in this type *)
   }
 
 (* Value expressions for the core language *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index d9a8b0fc7..7cf701d95 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -17,11 +17,12 @@ and type_variable =
 (* Value descriptions *)
 
 type value_description =
-  { val_type: type_expr;                (* Type of the val *)
-    val_prim: primitive_description }   (* Is this a primitive? *)
+  { val_type: type_expr;                       (* Type of the val *)
+    val_prim: primitive_description option }   (* Is this a primitive? *)
 and primitive_description =
-    Not_prim
-  | Primitive of string * int
+  { prim_name: string;
+    prim_arity: int;
+    prim_alloc: bool }
 
 (* Constructor descriptions *)
 
@@ -45,7 +46,7 @@ type label_description =
     lbl_arg: type_expr;                 (* Type of the argument *)
     lbl_mut: mutable_flag;              (* Is this a mutable field? *)
     lbl_pos: int;                       (* Position in block *)
-    lbl_all: label_description array     (* All the labels in this type *)
+    lbl_all: label_description array    (* All the labels in this type *)
   }
 
 (* Value expressions for the core language *)
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 139a8806c..0be7ad855 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -95,12 +95,7 @@ and transl_signature env sg =
   match sg with
     [] -> []
   | Psig_value(name, sdesc) :: srem ->
-      let ty = Typetexp.transl_type_scheme env sdesc.pval_type in
-      let prim =
-        match sdesc.pval_prim with
-          None -> Not_prim
-        | Some p -> Primitive(p, Ctype.arity ty) in
-      let desc = { val_type = ty; val_prim = prim } in
+      let desc = Typedecl.transl_value_decl env sdesc in
       let (id, newenv) = Env.enter_value name desc env in
       let rem = transl_signature newenv srem in
       Tsig_value(id, desc) :: rem
@@ -221,12 +216,7 @@ and type_structure env = function
        map_end make_sig_value bound_idents sig_rem,
        final_env)
   | Pstr_primitive(name, sdesc) :: srem ->
-      let ty = Typetexp.transl_type_scheme env sdesc.pval_type in
-      let prim =
-        match sdesc.pval_prim with
-          None -> Not_prim
-        | Some p -> Primitive(p, Ctype.arity ty) in
-      let desc = { val_type = ty; val_prim = prim } in
+      let desc = Typedecl.transl_value_decl env sdesc in
       let (id, newenv) = Env.enter_value name desc env in
       let (str_rem, sig_rem, final_env) = type_structure newenv srem in
       (Tstr_primitive(id, desc) :: str_rem,