add hidden arguments to type constructorshidden_args

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

17 files changed, 259 insertions, 139 deletions

diff --git a/typing/btype.ml b/typing/btype.ml
index e7de2a5e29..a6ea4dc48e 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -33,6 +33,8 @@ let newty2 level desc  =
   incr new_id; { desc = desc; level = level; id = !new_id }
 let newgenty desc      = newty2 generic_level desc
 let newgenvar ()       = newgenty Tvar
+let newgenconstr path args arity =
+  newgenty (Tconstr(path, args, arity, ref Mnil))
 (*
 let newmarkedvar level =
   incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
@@ -99,6 +101,15 @@ let hash_variant s =
   (* make it signed for 64 bits architectures *)
   if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
 
+let filter_bound l =
+  let rec filter bound = function
+      [] -> bound
+    | ty :: rem ->
+        let ty = repr ty in
+        if List.memq ty bound then filter bound rem
+        else filter (ty::bound) rem
+  in filter [] l
+
 
                   (**********************************)
                   (*  Utilities for type traversal  *)
@@ -124,9 +135,9 @@ let iter_type_expr f ty =
     Tvar                -> ()
   | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
   | Ttuple l            -> List.iter f l
-  | Tconstr (_, l, _)   -> List.iter f l
-  | Tobject(ty, {contents = Some (_, p)})
-                        -> f ty; List.iter f p
+  | Tconstr (_, l, _, _)-> List.iter f l
+  | Tobject(ty, {contents = Some (_, tl, _)})
+                        -> f ty; List.iter f tl
   | Tobject (ty, _)     -> f ty
   | Tvariant row        -> iter_row f row; f (row_more row)
   | Tfield (_, _, ty1, ty2) -> f ty1; f ty2
diff --git a/typing/btype.mli b/typing/btype.mli
index f831b39906..565d57694a 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -25,6 +25,8 @@ val newgenty: type_desc -> type_expr
         (* Create a generic type *)
 val newgenvar: unit -> type_expr
         (* Return a fresh generic variable *)
+val newgenconstr: Path.t -> type_expr list -> int -> type_expr
+        (* Return a generic constructor *)
 
 (* Use Tsubst instead
 val newmarkedvar: int -> type_expr
@@ -53,6 +55,8 @@ val static_row: row_desc -> bool
         (* Return whether the row is static or not *)
 val hash_variant: label -> int
         (* Hash function for variant tags *)
+val filter_bound: type_expr list -> type_expr list
+        (* Filter out (some) useless extra bound variables *)
 
 (**** Utilities for type traversal ****)
 
diff --git a/typing/ctype.ml b/typing/ctype.ml
index fc4472febc..6f18814063 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -143,7 +143,8 @@ let new_global_var ()  = newty2 !global_level Tvar
 
 let newobj fields      = newty (Tobject (fields, ref None))
 
-let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil))
+let newconstr path tyl arity =
+  newty (Tconstr (path, tyl, arity, ref Mnil))
 
 let none = newty (Ttuple [])                (* Clearly ill-formed type *)
 
@@ -246,11 +247,11 @@ let row_variable ty =
 (**** Object name manipulation ****)
 (* +++ Bientot obsolete *)
 
-let set_object_name id rv params ty =
+let set_object_name id rv params ar ty =
   match (repr ty).desc with
     Tobject (fi, nm) ->
       begin try
-        nm := Some (Path.Pident id, rv::params)
+        nm := Some (Path.Pident id, rv::params, ar)
       with Not_found ->
         ()
       end
@@ -260,7 +261,7 @@ let set_object_name id rv params ty =
 let remove_object_name ty =
   match (repr ty).desc with
     Tobject (_, nm)   -> nm := None
-  | Tconstr (_, _, _) -> ()
+  | Tconstr _         -> ()
   | _                 -> fatal_error "Ctype.remove_object_name"
 
 (**** Hiding of private methods ****)
@@ -496,7 +497,7 @@ let rec iter_generalize tyl ty =
   if (ty.level > !current_level) && (ty.level <> generic_level) then begin
     ty.level <- generic_level;
     begin match ty.desc with
-      Tconstr (_, _, abbrev) ->
+      Tconstr (_, _, _, abbrev) ->
         generalize_expans tyl !abbrev
     | _ -> ()
     end;
@@ -541,7 +542,7 @@ let rec update_level env level ty =
   let ty = repr ty in
   if ty.level > level then begin
     begin match ty.desc with
-      Tconstr(p, tl, abbrev)  when level < Path.binding_time p ->
+      Tconstr(p, tl, _, abbrev)  when level < Path.binding_time p ->
         (* Try first to replace an abbreviation by its expansion. *)
         begin try
           ty.desc <- Tlink (!try_expand_head' env ty);
@@ -669,7 +670,7 @@ let rec copy ty =
           Tarrow (l, copy t1, copy t2, c)
       | Ttuple tl ->
           Ttuple (List.map copy tl)
-      | Tconstr (p, tl, _) ->
+      | Tconstr (p, tl, ar, _) ->
           begin match find_repr p !(!abbreviations) with
             Some ty when repr ty != t -> (* XXX Commentaire... *)
               Tlink ty
@@ -683,7 +684,7 @@ let rec copy ty =
              ation can be released by changing the content of just
              one reference.
           *)
-              Tconstr (p, List.map copy tl,
+              Tconstr (p, List.map copy tl, ar,
                        ref (match !(!abbreviations) with
                               Mcons _ -> Mlink !abbreviations
                             | abbrev  -> abbrev))
@@ -693,8 +694,8 @@ let rec copy ty =
             match name with
               None ->
                 None
-            | Some (p, tl) ->
-                Some (p, List.map copy tl)
+            | Some (p, tl, ar) ->
+                Some (p, List.map copy tl, ar)
           in
           Tobject (copy t1, ref name')
       | Tvariant row0 ->
@@ -817,7 +818,7 @@ let rec subst env level abbrev ty params args body =
     let body0 = newvar () in          (* Stub *)
     begin match ty with
       None      -> ()
-    | Some ({desc = Tconstr (path, _, _)} as ty) ->
+    | Some ({desc = Tconstr (path, _, _, _)} as ty) ->
         memorize_abbrev abbrev path ty body0
     | _ ->
         assert false
@@ -829,7 +830,7 @@ let rec subst env level abbrev ty params args body =
     List.iter2 (!unify' env) params' args;
     current_level := old_level;
     body'
-  with Unify _ as exn ->
+  with exn ->
     current_level := old_level;
     raise exn
 
@@ -901,7 +902,7 @@ let expand_abbrev env ty =
     previous_env := env
   end;
   match ty with
-    {desc = Tconstr (path, args, abbrev); level = level} ->
+    {desc = Tconstr (path, args, ar, abbrev); level = level} ->
       begin match find_expans path !abbrev with
         Some ty ->
           if level <> generic_level then
@@ -956,7 +957,7 @@ let rec expand_head env ty =
    respect the type constraints *)
 let enforce_constraints env ty =
   match ty with
-    {desc = Tconstr (path, args, abbrev); level = level} ->
+    {desc = Tconstr (path, args, ar, abbrev); level = level} ->
       let decl = Env.find_type path env in
       ignore
         (subst env level (ref Mnil) None decl.type_params args (newvar2 level))
@@ -968,7 +969,7 @@ let enforce_constraints env ty =
 let rec full_expand env ty =
   let ty = repr (expand_head env ty) in
   match ty.desc with
-    Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar ->
+    Tobject (fi, {contents = Some (_, v::_, _)}) when (repr v).desc = Tvar ->
       newty2 ty.level (Tobject (fi, ref None))
   | _ ->
       ty
@@ -1004,7 +1005,7 @@ let rec non_recursive_abbrev env ty0 ty =
     let level = ty.level in
     visited := ty :: !visited;
     match ty.desc with
-      Tconstr(p, args, abbrev) ->
+      Tconstr(p, args, ar, abbrev) ->
         begin try
           non_recursive_abbrev env ty0 (try_expand_head env ty)
         with Cannot_expand ->
@@ -1030,7 +1031,7 @@ let correct_abbrev env ident params ty =
 let rec occur_rec env visited ty0 ty =
   if ty == ty0  then raise Occur;
   match ty.desc with
-    Tconstr(p, tl, abbrev) ->
+    Tconstr(p, tl, ar, abbrev) ->
       begin try
         if List.memq ty visited then raise Occur;
         iter_type_expr (occur_rec env (ty::visited) ty0) ty
@@ -1138,8 +1139,7 @@ let rec unify env t1 t2 =
         occur env t2 t1;
         update_level env t2.level t1;
         t2.desc <- Tlink t1
-    | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
-          when Path.same p1 p2
+    | (Tconstr (p1, [], _, a1), Tconstr (p2, [], _, a2)) when Path.same p1 p2
             (* This optimization assumes that t1 does not expand to t2
                (and conversely), so we fall back to the general case
                when any of the types has a cached expansion. *)
@@ -1204,14 +1204,15 @@ and unify3 env t1 t1' t2 t2' =
         end
     | (Ttuple tl1, Ttuple tl2) ->
         unify_list env tl1 tl2
-    | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+    | (Tconstr (p1, tl1, _, _), Tconstr (p2, tl2, _, _))
+      when Path.same p1 p2 ->
         unify_list env tl1 tl2
     | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
         unify_fields env fi1 fi2;
         (* Type [t2'] may have been instantiated by [unify_fields] *)
         (* XXX One should do some kind of unification... *)
         begin match (repr t2').desc with
-          Tobject (_, {contents = Some (_, va::_)})
+          Tobject (_, {contents = Some (_, va::_, _)})
                 when (repr va).desc = Tvar ->
             ()  
         | Tobject (_, nm2) ->
@@ -1232,7 +1233,7 @@ and unify3 env t1 t1' t2 t2' =
 (* XXX Commentaires + changer "create_recursion" *)
     if create_recursion then begin
       match t2.desc with
-        Tconstr (p, tl, abbrev) ->
+        Tconstr (p, tl, ar, abbrev) ->
           forget_abbrev abbrev p;
           let t2'' = expand_head env t2 in
           if not (closed_parameterized_type tl t2'') then
@@ -1248,13 +1249,13 @@ and unify3 env t1 t1' t2 t2' =
     *)
     if t1 != t1' (* && t2 != t2' *) then begin
       match (t1.desc, t2.desc) with
-        (Tconstr (p, ty::_, _), _)
+        (Tconstr (p, ty::_, _, _), _)
             when ((repr ty).desc <> Tvar)
               && weak_abbrev p
               && not (deep_occur t1 t2) ->
           update_level env t1.level t2;
           t1.desc <- Tlink t2
-      | (_, Tconstr (p, ty::_, _))
+      | (_, Tconstr (p, ty::_, _, _))
             when ((repr ty).desc <> Tvar)
               && weak_abbrev p
               && not (deep_occur t2 t1) ->
@@ -1330,7 +1331,7 @@ and unify_row env row1 row2 =
     then row2.row_name
     else None
   in
-  let bound = row1.row_bound @ row2.row_bound in
+  let bound = filter_bound (row1.row_bound @ row2.row_bound) in
   let row0 = {row_fields = []; row_more = more; row_bound = bound;
               row_closed = closed; row_name = name} in
   let more row rest =
@@ -1519,7 +1520,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
         moregen_occur env t1.level t2;
         occur env t1 t2;
         t1.desc <- Tlink t2
-    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+    | (Tconstr (p1, [], _, _), Tconstr (p2, [], _, _)) when Path.same p1 p2 ->
         ()
     | _ ->
         let t1' = expand_head env t1 in
@@ -1542,8 +1543,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
               moregen inst_nongen type_pairs env u1 u2
           | (Ttuple tl1, Ttuple tl2) ->
               moregen_list inst_nongen type_pairs env tl1 tl2
-          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
-                when Path.same p1 p2 ->
+          | (Tconstr (p1, tl1, _, _), Tconstr (p2, tl2, _, _))
+            when Path.same p1 p2 ->
               moregen_list inst_nongen type_pairs env tl1 tl2
           | (Tvariant row1, Tvariant row2) ->
               moregen_row inst_nongen type_pairs env row1 row2
@@ -1687,7 +1688,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
         with Not_found ->
           subst := (t1, t2) :: !subst
         end
-    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+    | (Tconstr (p1, [], _, _), Tconstr (p2, [], _, _)) when Path.same p1 p2 ->
         ()
     | _ ->
         let t1' = expand_head env t1 in
@@ -1712,8 +1713,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
               eqtype rename type_pairs subst env u1 u2;
           | (Ttuple tl1, Ttuple tl2) ->
               eqtype_list rename type_pairs subst env tl1 tl2
-          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
-                when Path.same p1 p2 ->
+          | (Tconstr (p1, tl1, _, _), Tconstr (p2, tl2, _, _))
+            when Path.same p1 p2 ->
               eqtype_list rename type_pairs subst env tl1 tl2
           | (Tvariant row1, Tvariant row2) ->
               eqtype_row rename type_pairs subst env row1 row2
@@ -2107,7 +2108,7 @@ let rec build_subtype env visited posi t =
       if List.exists snd tlist' then
         (newty (Ttuple (List.map fst tlist')), true)
       else (t, false)
-  | Tconstr(p, tl, abbrev) when generic_abbrev env p ->
+  | Tconstr(p, tl, ar, abbrev) when generic_abbrev env p ->
       let t' = repr (expand_abbrev env t) in
       let (t'', c) =
         try match t'.desc with
@@ -2133,7 +2134,7 @@ let rec build_subtype env visited posi t =
               let ty = repr ty in
               let ty1 =
                 match ty.desc with
-                  Tobject(ty1,{contents=Some(p',_)}) ->
+                  Tobject(ty1,{contents=Some(p',_,_)}) ->
                     if Path.same p p' then ty1 else raise Not_found
                 | _ -> assert false in
               ty.desc <- Tvar;
@@ -2149,7 +2150,7 @@ let rec build_subtype env visited posi t =
         with Not_found -> build_subtype env visited posi t'
       in
       if c then (t'', true) else (t, false)
-  | Tconstr(p, tl, abbrev) ->
+  | Tconstr(p, tl, ar, abbrev) ->
       let decl = Env.find_type p env in
       let tl' =
         List.map2
@@ -2163,7 +2164,9 @@ let rec build_subtype env visited posi t =
           decl.type_variance tl
       in
       if List.exists snd tl' then
-        (newconstr p (List.map fst tl'), true)
+        let t' = newconstr p (List.map fst tl') ar in
+        enforce_constraints env t';
+        (t', true)
       else
         (t, false)
   | Tvariant row ->
@@ -2274,13 +2277,13 @@ let rec subtype_rec env trace t1 t2 cstrs =
         subtype_rec env ((u1, u2)::trace) u1 u2 cstrs
     | (Ttuple tl1, Ttuple tl2) ->
         subtype_list env trace tl1 tl2 cstrs
-    | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
+    | (Tconstr(p1, [], _, _), Tconstr(p2, [], _, _)) when Path.same p1 p2 ->
         cstrs
-    | (Tconstr(p1, tl1, abbrev1), _) when generic_abbrev env p1 ->
+    | (Tconstr(p1, tl1, _, abbrev1), _) when generic_abbrev env p1 ->
         subtype_rec env trace (expand_abbrev env t1) t2 cstrs
-    | (_, Tconstr(p2, tl2, abbrev2)) when generic_abbrev env p2 ->
+    | (_, Tconstr(p2, tl2, _, abbrev2)) when generic_abbrev env p2 ->
         subtype_rec env trace t1 (expand_abbrev env t2) cstrs
-    | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
+    | (Tconstr(p1, tl1, _, _), Tconstr(p2, tl2, _, _)) when Path.same p1 p2 ->
         let decl = Env.find_type p1 env in
         List.fold_left2
           (fun cstrs (co, cn) (t1, t2) ->
@@ -2382,14 +2385,14 @@ let unalias ty =
   | _ ->
       newty2 ty.level ty.desc
 
-let unroll_abbrev id tl ty =
+let unroll_abbrev id tl ar ty =
   let ty = repr ty in
   if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl) then
     ty
   else
     let ty' = newty2 ty.level ty.desc in
     ty.desc <- Tlink (newty2 ty.level
-                             (Tconstr (Path.Pident id, tl, ref Mnil)));
+                        (Tconstr (Path.Pident id, tl, ar, ref Mnil)));
     ty'
 
 (* Return the arity (as for curried functions) of the given type. *)
@@ -2402,9 +2405,9 @@ let rec arity ty =
 let rec cyclic_abbrev env id ty =
   let ty = repr ty in
   match ty.desc with
-    Tconstr (Path.Pident id', _, _) when Ident.same id id' ->
+    Tconstr (Path.Pident id', _, _, _) when Ident.same id id' ->
       true
-  | Tconstr (p, tl, abbrev) ->
+  | Tconstr (p, tl, _, abbrev) ->
       begin try
         cyclic_abbrev env id (try_expand_head env ty)
       with Cannot_expand ->
@@ -2440,18 +2443,16 @@ let rec normalize_type_rec env ty =
               else f
             | _ -> f)
           row.row_fields
-      and bound = List.fold_left
-          (fun tyl ty -> if List.memq ty tyl then tyl else ty :: tyl)
-          [] (List.map repr row.row_bound)
-      in ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound}
+      and bound = filter_bound row.row_bound in
+      ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound}
     | Tobject (_, nm) ->
         begin match !nm with
         | None -> ()
-        | Some (n, v :: l) ->
+        | Some (n, v :: l, ar) ->
             let v' = repr v in
             begin match v'.desc with
-            | Tvar -> if v' != v then nm := Some (n, v' :: l)
-            | Tnil -> ty.desc <- Tconstr (n, l, ref Mnil)
+            | Tvar -> if v' != v then nm := Some (n, v' :: l, ar)
+            | Tnil -> ty.desc <- Tconstr (n, l, ar, ref Mnil)
             | _ -> nm := None
             end
         | _ ->
@@ -2502,7 +2503,7 @@ let rec nondep_type_rec env id ty =
           Tarrow(l, nondep_type_rec env id t1, nondep_type_rec env id t2, c)
       | Ttuple tl ->
           Ttuple(List.map (nondep_type_rec env id) tl)
-      | Tconstr(p, tl, abbrev) ->
+      | Tconstr(p, tl, ar, abbrev) ->
           if Path.isfree id p then
             begin try
               Tlink (nondep_type_rec env id
@@ -2517,14 +2518,14 @@ let rec nondep_type_rec env id ty =
               raise Not_found
             end
           else
-            Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil)
+            Tconstr(p, List.map (nondep_type_rec env id) tl, ar, ref Mnil)
       | Tobject (t1, name) ->
           Tobject (nondep_type_rec env id t1,
                  ref (match !name with
                         None -> None
-                      | Some (p, tl) ->
-                          if Path.isfree id p then None
-                          else Some (p, List.map (nondep_type_rec env id) tl)))
+                      | Some (p, tl, ar) ->
+                          if Path.isfree id p then None else
+                          Some (p, List.map (nondep_type_rec env id) tl, ar)))
       | Tvariant row ->
           let row = row_repr row in
           let more = repr row.row_more in
@@ -2625,7 +2626,8 @@ let nondep_type_decl env mid id is_covariant decl =
             match decl.type_manifest with
               None -> None
             | Some ty ->
-                Some (unroll_abbrev id params (nondep_type_rec env mid ty))
+                Some (unroll_abbrev id params decl.type_arity
+                        (nondep_type_rec env mid ty))
           with Not_found when is_covariant ->
             None
           end;
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 4510dfafc8..2de13d65be 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -44,7 +44,7 @@ val new_global_var: unit -> type_expr
         (* Return a fresh variable, bound at toplevel
            (as type variables ['a] in type constraints). *)
 val newobj: type_expr -> type_expr
-val newconstr: Path.t -> type_expr list -> type_expr
+val newconstr: Path.t -> type_expr list -> int -> type_expr
 val none: type_expr
         (* A dummy type expression *)
 
@@ -67,7 +67,7 @@ val close_object: type_expr -> unit
 val row_variable: type_expr -> type_expr
         (* Return the row variable of an open object type *)
 val set_object_name:
-        Ident.t -> type_expr -> type_expr list -> type_expr -> unit
+        Ident.t -> type_expr -> type_expr list -> int -> type_expr -> unit
 val remove_object_name: type_expr -> unit
 val hide_private_methods: type_expr -> unit
 
diff --git a/typing/env.ml b/typing/env.ml
index fd2bf67eef..6fd2f2f11f 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -362,7 +362,7 @@ let constructors_of_type ty_path decl =
   match decl.type_kind with
     Type_variant cstrs ->
       Datarepr.constructor_descrs
-        (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+        (Btype.newgenconstr ty_path decl.type_params decl.type_arity)
         cstrs
   | _ -> []
 
@@ -372,7 +372,7 @@ let labels_of_type ty_path decl =
   match decl.type_kind with
     Type_record(labels, rep) ->
       Datarepr.label_descrs
-        (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+        (Btype.newgenconstr ty_path decl.type_params decl.type_arity)
         labels rep
   | _ -> []
 
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 9a8c941473..a59d566013 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -68,8 +68,7 @@ let type_declarations env id decl1 decl2 =
                              (ty2::decl2.type_params)
     | (None, Some ty2) ->
         let ty1 =
-          Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
-        in
+          Btype.newgenconstr (Pident id) decl2.type_params decl2.type_arity in
         Ctype.equal env true decl1.type_params decl2.type_params &&
         Ctype.equal env false [ty1] [ty2]
   end &&
diff --git a/typing/mtype.ml b/typing/mtype.ml
index d984a32a36..26d52da326 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -47,8 +47,8 @@ and strengthen_sig env sg p =
         match decl.type_manifest with
           None ->
             { decl with type_manifest =
-                Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
-                                            decl.type_params, ref Mnil))) }
+                Some(Btype.newgenconstr (Pdot(p, Ident.name id, nopos))
+                       decl.type_params decl.type_arity) }
         | _ -> decl in
       Tsig_type(id, newdecl) :: strengthen_sig env rem p
   | (Tsig_exception(id, d) as sigelt) :: rem ->
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 7310e579ad..fa23730a07 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -29,7 +29,7 @@ exception Empty (* Empty pattern *)
 let get_type_descr ty tenv =
   let ty = Ctype.repr (Ctype.expand_head tenv ty) in
   match ty.desc with
-  | Tconstr (path,_,_) -> Env.find_type path tenv
+  | Tconstr (path,_,_,_) -> Env.find_type path tenv
   | _ -> fatal_error "Parmatch.get_type_descr"
 
 let get_constr tag ty tenv =
diff --git a/typing/predef.ml b/typing/predef.ml
index b2d1bf22a5..9a54b93325 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -48,19 +48,19 @@ and path_nativeint = Pident ident_nativeint
 and path_int32 = Pident ident_int32
 and path_int64 = Pident ident_int64
 
-let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
-and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
-and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
-and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
-and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
-and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
-and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
-and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
-and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
-and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
-and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
-and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
-and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
+let type_int = newgenconstr path_int [] 0
+and type_char = newgenconstr path_char [] 0
+and type_string = newgenconstr path_string [] 0
+and type_float = newgenconstr path_float [] 0
+and type_bool = newgenconstr path_bool [] 0
+and type_unit = newgenconstr path_unit [] 0
+and type_exn = newgenconstr path_exn [] 0
+and type_array t = newgenconstr path_array [t] 1
+and type_list t = newgenconstr path_list [t] 1
+and type_option t = newgenconstr path_option [t] 1
+and type_nativeint = newgenconstr path_nativeint [] 0
+and type_int32 = newgenconstr path_int32 [] 0
+and type_int64 = newgenconstr path_int64 [] 0
 
 let ident_match_failure = Ident.create "Match_failure"
 and ident_out_of_memory = Ident.create "Out_of_memory"
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index e396585893..a88423ca9d 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -23,6 +23,13 @@ open Asttypes
 open Types
 open Btype
 
+(* Misc *)
+let rec firsts n l =
+  if n = 0 then [] else
+  match l with
+    []     -> invalid_arg "Typetexp.firsts"
+  | a :: l -> a :: firsts (n-1) l
+
 (* Print a long identifier *)
 
 let rec longident ppf = function
@@ -106,8 +113,8 @@ let rec mark_loops_rec visited ty =
     | Tarrow(_, ty1, ty2, _) ->
         mark_loops_rec visited ty1; mark_loops_rec visited ty2
     | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
-    | Tconstr(_, tyl, _) ->
-        List.iter (mark_loops_rec visited) tyl
+    | Tconstr(_, tyl, ar, _) ->
+        List.iter (mark_loops_rec visited) (firsts ar tyl)
     | Tvariant row ->
         let row = row_repr row in
         if List.memq px !visited_objects then add_alias px else
@@ -128,8 +135,8 @@ let rec mark_loops_rec visited ty =
           begin match !nm with
           | None ->
               mark_loops_rec visited fi
-          | Some (_, l) ->
-              List.iter (mark_loops_rec visited) l
+          | Some (_, l, ar) ->
+              List.iter (mark_loops_rec visited) (firsts ar (List.tl l))
           end
         end
     | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
@@ -186,7 +193,8 @@ let rec typexp sch prio0 ppf ty =
           print_label ppf l;
           if is_optional l then
             match (repr ty1).desc with
-            | Tconstr(path, [ty], _) when Path.same path Predef.path_option ->
+            | Tconstr(path, [ty], _, _)
+              when Path.same path Predef.path_option ->
                 typexp sch 2 ppf ty
             | _ -> fprintf ppf "<hidden>"
           else typexp sch 2 ppf ty1;
@@ -198,8 +206,8 @@ let rec typexp sch prio0 ppf ty =
         if prio >= 3
         then fprintf ppf "@[<1>(%a)@]" (typlist sch 3 " *") tyl
         else fprintf ppf "@[<0>%a@]" (typlist sch 3 " *") tyl
-    | Tconstr(p, tyl, abbrev) ->
-        fprintf ppf "@[%a%a@]" (typargs sch) tyl path p
+    | Tconstr(p, tyl, ar, abbrev) ->
+        fprintf ppf "@[%a%a@]" (typargs sch) (firsts ar tyl) path p
     | Tvariant row ->
         let row = row_repr row in
         let fields =
@@ -307,8 +315,9 @@ and typobject sch ty fi ppf nm =
           Sort.list (fun (n, _) (n', _) -> n <= n') present_fields in
         typfields sch rest ppf sorted_fields in
       fprintf ppf "@[<2>< %a >@]" pr_fields fi
-  | Some (p, {desc = Tvar} :: tyl) ->
-      fprintf ppf "@[%a%s#%a@]" (typargs sch) tyl (non_gen_mark sch ty) path p
+  | Some (p, {desc = Tvar} :: tyl, ar) ->
+      fprintf ppf "@[%a%s#%a@]" (typargs sch) (firsts ar tyl)
+        (non_gen_mark sch ty) path p
   | _ ->
         fatal_error "Printtyp.typobject"
   end
@@ -361,7 +370,7 @@ let rec type_decl kwd id ppf decl =
 
   reset();
 
-  let params = filter_params decl.type_params in
+  let params = filter_params (firsts decl.type_arity decl.type_params) in
 
   aliased := params @ !aliased;
   List.iter mark_loops params;
@@ -395,7 +404,8 @@ let rec type_decl kwd id ppf decl =
         (List.combine params decl.type_variance)
         ident id
     else
-      type_expr ppf (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)))
+      type_expr ppf
+        (Btype.newgenconstr (Pident id) decl.type_params decl.type_arity)
   in
   let print_manifest ppf decl =
     match decl.type_manifest with
@@ -534,8 +544,9 @@ let rec perform_class_type sch params ppf = function
       let ty =
        if is_optional l then
          match (repr ty).desc with
-         | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty
-         | _ -> newconstr (Path.Pident(Ident.create "<hidden>")) []
+         | Tconstr(path, [ty], _, _) when Path.same path Predef.path_option ->
+             ty
+         | _ -> newconstr (Path.Pident(Ident.create "<hidden>")) [] 0
        else ty in
       fprintf ppf "@[%a%a ->@ %a@]"
        print_label l (typexp sch 2) ty (perform_class_type sch params) cty
@@ -706,12 +717,12 @@ let unification_error unif tr txt1 ppf txt2 =
         match t3.desc, t4.desc with
         | Tfield _, Tvar | Tvar, Tfield _ ->
             fprintf ppf "@,Self type cannot escape its class"
-        | Tconstr (p, _, _), Tvar
+        | Tconstr (p, _, _, _), Tvar
             when unif && t4.level < Path.binding_time p ->
             fprintf ppf
               "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
               path p
-        | Tvar, Tconstr (p, _, _)
+        | Tvar, Tconstr (p, _, _, _)
             when unif && t3.level < Path.binding_time p ->
             fprintf ppf
               "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
diff --git a/typing/subst.ml b/typing/subst.ml
index 7fd90c4a35..67d8c41701 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -81,14 +81,14 @@ let rec typexp s ty =
           Tarrow(l, typexp s t1, typexp s t2, c)
       | Ttuple tl ->
           Ttuple(List.map (typexp s) tl)
-      | Tconstr(p, tl, abbrev) ->
-          Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
+      | Tconstr(p, tl, arity, abbrev) ->
+          Tconstr(type_path s p, List.map (typexp s) tl, arity, ref Mnil)
       | Tobject (t1, name) ->
           Tobject (typexp s t1,
                  ref (match !name with
                         None -> None
-                      | Some (p, tl) ->
-                          Some (type_path s p, List.map (typexp s) tl)))
+                      | Some (p, tl, ar) ->
+                          Some (type_path s p, List.map (typexp s) tl, ar)))
       | Tvariant row ->
           let row = row_repr row in
           let more = repr row.row_more in
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 836fd17039..0ab57b4ce8 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -862,7 +862,8 @@ let class_infos define_class kind
 
   (* Check the abbreviation for the object type *)
   let (obj_params', obj_type) = Ctype.instance_class params typ in
-  let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
+  let arity = List.length obj_params' in
+  let constr = Ctype.newconstr (Path.Pident obj_id) obj_params arity in
   begin
     let ty = Ctype.self_type obj_type in
     Ctype.hide_private_methods ty;
@@ -873,7 +874,7 @@ let class_infos define_class kind
       raise(Error(cl.pci_loc,
             Bad_parameters (obj_id, constr,
                             Ctype.newconstr (Path.Pident obj_id)
-                                            obj_params')))
+                                            obj_params' arity)))
     end;
     begin try
       Ctype.unify env ty constr
@@ -888,21 +889,21 @@ let class_infos define_class kind
     let (cl_params', cl_type) = Ctype.instance_class params typ in
     let ty = Ctype.self_type cl_type in
     Ctype.hide_private_methods ty;
-    Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
+    Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params arity ty;
     begin try
       List.iter2 (Ctype.unify env) cl_params cl_params'
     with Ctype.Unify _ ->
       raise(Error(cl.pci_loc,
             Bad_parameters (cl_id,
                             Ctype.newconstr (Path.Pident cl_id)
-                                            cl_params,
+                                            cl_params arity,
                             Ctype.newconstr (Path.Pident cl_id)
-                                            cl_params')))
+                                            cl_params' arity )))
     end;
     begin try
       Ctype.unify env ty cl_ty
     with Ctype.Unify _ ->
-      let constr = Ctype.newconstr (Path.Pident cl_id) params in
+      let constr = Ctype.newconstr (Path.Pident cl_id) params arity in
       raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty)))
     end
   end;
@@ -972,7 +973,8 @@ let class_infos define_class kind
     Ctype.instance_parameterized_type params (Ctype.self_type typ)
   in
   Ctype.hide_private_methods cl_ty;
-  Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
+  Ctype.set_object_name obj_id (Ctype.row_variable cl_ty)
+    cl_params arity cl_ty;
   let cl_abbr =
     {type_params = cl_params;
      type_arity = List.length cl_params;
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 1ac29ee479..4f94eba621 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -74,8 +74,7 @@ let type_constant = function
 
 (* Specific version of type_option, using newty rather than newgenty *)
 
-let type_option ty =
-  newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+let type_option ty = newconstr Predef.path_option [ty] 1
 
 let option_none ty loc =
   let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in
@@ -88,14 +87,14 @@ let option_some texp =
     exp_type = type_option texp.exp_type; exp_env = texp.exp_env }
 
 let extract_option_type env ty =
-  match expand_head env ty with {desc = Tconstr(path, [ty], _)}
+  match expand_head env ty with {desc = Tconstr(path, [ty], _, _)}
     when Path.same path Predef.path_option -> ty
   | _ -> assert false
 
 let rec extract_label_names env ty =
   let ty = repr ty in
   match ty.desc with
-  | Tconstr (path, _, _) ->
+  | Tconstr (path, _, _, _) ->
       let td = Env.find_type path env in
       begin match td.type_kind with
       | Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields
@@ -205,7 +204,7 @@ let build_or_pat env loc lid =
   in
   let tyl = List.map (fun _ -> newvar()) decl.type_params in
   let fields =
-    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
+    let ty = expand_head env (newconstr path tyl decl.type_arity) in
     match ty.desc with
       Tvariant row when static_row row ->
         (row_repr row).row_fields
@@ -559,9 +558,7 @@ let type_format loc fmt =
             raise(Error(loc, Bad_format(String.sub fmt i (j-i+1))))
         end
     | _ -> scan_format (i+1) in
-  newty
-    (Tconstr(Predef.path_format, [scan_format 0; ty_input; ty_result],
-             ref Mnil))
+  newconstr Predef.path_format [scan_format 0; ty_input; ty_result] 3
 
 (* Approximate the type of an expression, for better recursion *)
 
@@ -1278,7 +1275,7 @@ and type_expect env sexp ty_expected =
           exp_type =
             (* Terrible hack for format strings *)
             begin match (repr ty_expected).desc with
-              Tconstr(path, _, _) when Path.same path Predef.path_format ->
+              Tconstr(path, _, _, _) when Path.same path Predef.path_format ->
                 type_format sexp.pexp_loc s
             | _ -> instance Predef.type_string
             end;
@@ -1366,7 +1363,7 @@ and type_statement env sexp =
     | Tarrow _ ->
         Location.prerr_warning sexp.pexp_loc Warnings.Partial_application;
         exp
-    | Tconstr (p, _, _) when Path.same p Predef.path_unit -> exp
+    | Tconstr (p, _, _, _) when Path.same p Predef.path_unit -> exp
     | Tvar -> exp
     | _ ->
         Location.prerr_warning sexp.pexp_loc Warnings.Statement_type;
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 920951b63e..c35839a2b2 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -22,6 +22,15 @@ open Types
 open Typedtree
 open Typetexp
 
+(* Misc *)
+let rec skip n l =
+  if n = 0 then l else
+  match l with [] -> invalid_arg "Typedecl.skip"
+  | _ :: l -> skip (n-1) l
+
+let rec build_list n f =
+  if n = 0 then [] else f () :: build_list (n-1) f
+
 type error =
     Repeated_parameter
   | Duplicate_constructor of string
@@ -64,7 +73,7 @@ let update_type temp_env env id loc =
   match decl.type_manifest with None -> ()
   | Some ty ->
       let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
-      try Ctype.unify env (Ctype.newconstr path params) ty
+      try Ctype.unify env (Ctype.newconstr path params decl.type_arity) ty
       with Ctype.Unify trace ->
         raise (Error(loc, Type_clash trace))
 
@@ -72,7 +81,7 @@ let update_type temp_env env id loc =
 
 let is_float env ty =
   match Ctype.repr (Ctype.expand_head env ty) with
-    {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
+    {desc = Tconstr(p, _, _, _)} -> Path.same p Predef.path_float
   | _ -> false
 
 (* Translate one type declaration *)
@@ -187,10 +196,10 @@ let rec check_constraints_rec env loc visited ty =
   if TypeSet.mem ty !visited then () else begin
   visited := TypeSet.add ty !visited;
   match ty.desc with
-  | Tconstr (path, args, _) ->
+  | Tconstr (path, args, ar, _) ->
       Ctype.begin_def ();
       let args' = List.map (fun _ -> Ctype.newvar ()) args in
-      let ty' = Ctype.newconstr path args' in
+      let ty' = Ctype.newconstr path args' ar in
       begin try Ctype.enforce_constraints env ty'
       with Ctype.Unify _ -> assert false
       end;
@@ -250,7 +259,7 @@ let check_abbrev env (_, sdecl) (id, decl) =
   match decl with
     {type_kind = (Type_variant _ | Type_record _); type_manifest = Some ty} ->
       begin match (Ctype.repr ty).desc with
-        Tconstr(path, args, _) ->
+        Tconstr(path, args, _, _) ->
           begin try
             let decl' = Env.find_type path env in
             if List.length args = List.length decl.type_params
@@ -288,10 +297,10 @@ let rec check_expansion_rec env id args loc id_check_list visited ty =
   if List.memq ty visited then () else
   let visited = ty :: visited in
   begin match ty.desc with
-  | Tconstr(Path.Pident id' as path, args', _) ->
+  | Tconstr(Path.Pident id' as path, args', ar, _) ->
       if Ident.same id id' then begin
         if not (Ctype.equal env false args args') then
-          raise (Error(loc, Parameters_differ(ty, Ctype.newconstr path args)))
+          raise(Error(loc,Parameters_differ(ty, Ctype.newconstr path args ar)))
       end else begin try
         let (loc, checked) = List.assoc id' id_check_list in
         if List.exists (Ctype.equal env false args') !checked then () else
@@ -343,7 +352,7 @@ let compute_variance env tvl nega posi ty =
           compute_variance_rec posi nega ty2
       | Ttuple tl ->
           List.iter (compute_variance_rec posi nega) tl
-      | Tconstr (path, tl, _) ->
+      | Tconstr (path, tl, _, _) ->
           if tl = [] then () else
           let decl = Env.find_type path env in
           List.iter2
@@ -436,6 +445,78 @@ let compute_variance_decls env decls =
     List.map (fun (l,_) -> List.map (fun _ -> false, false) l) required in
   fst (compute_variance_fixpoint env decls required variances)
 
+(* Hidden arguments *)
+let rec hidden_params env decls visited hidden others ty =
+  let ty = Btype.repr ty in
+  if TypeSet.mem ty !visited then () else begin
+    visited := TypeSet.add ty !visited;
+    begin match ty.desc with
+      Tconstr (Path.Pident id, tyl, _, _) when List.mem_assoc id decls ->
+        others := TypeSet.add ty !others
+    | Tconstr (path, tyl, _, _) ->
+        let decl = Env.find_type path env in
+        let h = skip decl.type_arity tyl in
+        hidden := List.fold_right TypeSet.add h !hidden
+    | Tvariant row ->
+        hidden := TypeSet.add (Btype.row_more row) !hidden
+    | _ -> ()
+    end;
+    Btype.iter_type_expr (hidden_params env decls visited hidden others) ty
+  end
+
+let hidden_params_decl env decls (id, decl) =
+  let hidden = ref TypeSet.empty
+  and visited = ref TypeSet.empty
+  and others = ref TypeSet.empty in
+  begin match decl.type_kind, decl.type_manifest with
+  | Type_variant l, _ ->
+      List.iter
+        (fun (_, tyl) ->
+          List.iter (hidden_params env decls visited hidden others) tyl)
+        l
+  | Type_record (l, _), _ ->
+      List.iter
+        (fun (_, _, ty) -> hidden_params env decls visited hidden others ty)
+        l
+  | Type_abstract, Some ty ->
+      hidden_params env decls visited hidden others ty
+  | _ -> ()
+  end;
+  !hidden, !others
+
+let more_hidden_params hiddens others n =
+  TypeSet.fold
+    (function {desc=Tconstr (Path.Pident id, tyl, _, _)} ->
+      (+) (List.assoc id hiddens)
+    | _ -> assert false)
+    others n
+
+let insert_hidden_params hiddens (id, decl) (hidden, others) =
+  let params = ref (List.rev decl.type_params) in
+  TypeSet.iter (fun ty -> params := ty :: !params) hidden;
+  TypeSet.iter
+    (function {desc=Tconstr (Path.Pident id as p, tyl, ar, r)} as ty ->
+      let n = List.assoc id hiddens in
+      let args = build_list n Btype.newgenvar in
+      ty.desc <- Tconstr (p, tyl @ args, ar, r);
+      params := List.rev_append args !params
+    | _ -> assert false)
+    others;
+  (id, {decl with type_params = List.rev !params})
+
+let compute_hidden_params env decls =
+  let hidden_others = List.map (hidden_params_decl env decls) decls in
+  let hidden, others = List.split hidden_others in
+  let ids = List.map fst decls in
+  let rec fix hiddens =
+    let ids_hiddens = List.combine ids hiddens in
+    let hiddens' = List.map2 (more_hidden_params ids_hiddens) others hiddens in
+    if hiddens' <> hiddens then fix hiddens' else hiddens
+  in
+  let hiddens = fix (List.map TypeSet.cardinal hidden) in
+  let ids_hiddens = List.combine ids hiddens in
+  List.map2 (insert_hidden_params ids_hiddens) decls hidden_others
+
 (* Translate a set of mutually recursive type declarations *)
 let transl_type_decl env name_sdecl_list =
   (* Create identifiers. *)
@@ -490,10 +571,16 @@ let transl_type_decl env name_sdecl_list =
       id_list name_sdecl_list
   in
   List.iter (check_expansion newenv (List.flatten id_loc_list)) decls;
+  (* extra parameters *)
+  let decls = compute_hidden_params newenv decls in
   (* Add variances to the environment *)
   let required =
-    List.map (fun (_, sdecl) -> sdecl.ptype_variance, sdecl.ptype_loc)
-      name_sdecl_list
+    List.map2
+      (fun (_, sdecl) (_, decl) ->
+        sdecl.ptype_variance @ replicate_list (false,false)
+          (List.length decl.type_params - decl.type_arity),
+        sdecl.ptype_loc)
+      name_sdecl_list decls
   in
   let final_decls, final_env =
     compute_variance_fixpoint env decls required
diff --git a/typing/types.ml b/typing/types.ml
index f1ed0cf01e..230cf8b142 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -28,8 +28,8 @@ and type_desc =
     Tvar
   | Tarrow of label * type_expr * type_expr * commutable
   | Ttuple of type_expr list
-  | Tconstr of Path.t * type_expr list * abbrev_memo ref
-  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  | Tconstr of Path.t * type_expr list * int * abbrev_memo ref
+  | Tobject of type_expr * (Path.t * type_expr list * int) option ref
   | Tfield of string * field_kind * type_expr * type_expr
   | Tnil
   | Tlink of type_expr
diff --git a/typing/types.mli b/typing/types.mli
index 95ac8c887e..561a1d082d 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -27,8 +27,8 @@ and type_desc =
     Tvar
   | Tarrow of label * type_expr * type_expr * commutable
   | Ttuple of type_expr list
-  | Tconstr of Path.t * type_expr list * abbrev_memo ref
-  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  | Tconstr of Path.t * type_expr list * int * abbrev_memo ref
+  | Tobject of type_expr * (Path.t * type_expr list * int) option ref
   | Tfield of string * field_kind * type_expr * type_expr
   | Tnil
   | Tlink of type_expr
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index b30e8d5a4f..94a573d2c9 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -19,6 +19,13 @@ open Parsetree
 open Types
 open Ctype
 
+(* Misc *)
+let rec firsts n l =
+  if n = 0 then [] else
+  match l with
+    []     -> invalid_arg "Typetexp.firsts"
+  | a :: l -> a :: firsts (n-1) l
+
 exception Already_bound
 
 type error =
@@ -131,8 +138,8 @@ let rec transl_type env policy styp =
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
       let args = List.map (transl_type env policy) stl in
-      let params = List.map (fun _ -> Ctype.newvar ()) args in
-      let cstr = newty (Tconstr(path, params, ref Mnil)) in
+      let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+      let cstr = newconstr path params decl.type_arity in
       begin try
         Ctype.enforce_constraints env cstr
       with Unify trace ->
@@ -142,7 +149,7 @@ let rec transl_type env policy styp =
         (fun (sty, ty) ty' ->
            try unify env ty ty' with Unify trace ->
              raise (Error(sty.ptyp_loc, Type_mismatch trace)))
-        (List.combine stl args) params;
+        (List.combine stl args) (firsts decl.type_arity params);
       cstr
   | Ptyp_object fields ->
       newobj (transl_fields env policy fields)
@@ -175,18 +182,18 @@ let rec transl_type env policy styp =
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
       let args = List.map (transl_type env policy) stl in
-      let cstr = newty (Tconstr(path, args, ref Mnil)) in
+      let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+      let cstr = newconstr path params decl.type_arity in
       let ty =
         try Ctype.expand_head env cstr
         with Unify trace ->
           raise (Error(styp.ptyp_loc, Type_mismatch trace))
       in
-      let params = Ctype.instance_list decl.type_params in
       List.iter2
-        (fun (sty, ty') ty ->
-           try unify env ty' ty with Unify trace ->
+        (fun (sty, ty) ty' ->
+           try unify env ty ty' with Unify trace ->
              raise (Error(sty.ptyp_loc, Type_mismatch trace)))
-        (List.combine stl args) params;
+        (List.combine stl args) (firsts decl.type_arity params);
       begin match ty.desc with
         Tvariant row ->
           let row = Btype.row_repr row in