Keep more type information in Lambda (#2156)

* Propagate type information about function parameters and return

* Keep value kind on staticcatch parameters

Changes

@@ -589,6 +589,10 @@ Working version
   of mutually-recursive type declarations.
   (Gabriel Scherer, review by Armaël Guéneau)
 
+- GPR#2156: propagate more type information through Lambda and Clambda
+  intermediate language, as a preparation step for more future optimizations
+  (Pierre Chambart and Alain Frisch, cross-reviewed by themselves)
+
 ### Bug fixes:
 
 - MPR#7867: Fix #mod_use raising an exception for filenames with no

asmcomp/clambda.ml

@@ -60,7 +60,11 @@ and ulambda =
   | Uswitch of ulambda * ulambda_switch * Debuginfo.t
   | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
   | Ustaticfail of int * ulambda list
-  | Ucatch of int * Backend_var.With_provenance.t list * ulambda * ulambda
+  | Ucatch of
+      int *
+      (Backend_var.With_provenance.t * value_kind) list *
+      ulambda *
+      ulambda
   | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda
   | Uifthenelse of ulambda * ulambda * ulambda
   | Usequence of ulambda * ulambda
@@ -74,7 +78,8 @@ and ulambda =
 and ufunction = {
   label  : function_label;
   arity  : int;
-  params : Backend_var.With_provenance.t list;
+  params : (Backend_var.With_provenance.t * value_kind) list;
+  return : value_kind;
   body   : ulambda;
   dbg    : Debuginfo.t;
   env    : Backend_var.t option;

asmcomp/clambda.mli

@@ -71,7 +71,11 @@ and ulambda =
   | Uswitch of ulambda * ulambda_switch * Debuginfo.t
   | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
   | Ustaticfail of int * ulambda list
-  | Ucatch of int * Backend_var.With_provenance.t list * ulambda * ulambda
+  | Ucatch of
+      int *
+      (Backend_var.With_provenance.t * value_kind) list *
+      ulambda *
+      ulambda
   | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda
   | Uifthenelse of ulambda * ulambda * ulambda
   | Usequence of ulambda * ulambda
@@ -85,7 +89,8 @@ and ulambda =
 and ufunction = {
   label  : function_label;
   arity  : int;
-  params : Backend_var.With_provenance.t list;
+  params : (Backend_var.With_provenance.t * value_kind) list;
+  return : value_kind;
   body   : ulambda;
   dbg    : Debuginfo.t;
   env    : Backend_var.t option;

asmcomp/closure.ml

@@ -654,10 +654,12 @@ let rec substitute loc fpc sb rn ulam =
           let new_nfail = next_raise_count () in
           new_nfail, Some (Int.Map.add nfail new_nfail rn)
         | None -> nfail, rn in
-      let ids' = List.map VP.rename ids in
+      let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in
       let sb' =
         List.fold_right2
-          (fun id id' s -> V.Map.add (VP.var id) (Uvar (VP.var id')) s)
+          (fun (id, _) (id', _) s ->
+             V.Map.add (VP.var id) (Uvar (VP.var id')) s
+          )
           ids ids' sb
       in
       Ucatch(nfail, ids', substitute loc fpc sb rn u1,
@@ -923,7 +925,8 @@ let rec close fenv cenv = function
         let (new_fun, approx) = close fenv cenv
           (Lfunction{
                kind = Curried;
-               params = final_args;
+               return = Pgenval;
+               params = List.map (fun v -> v, Pgenval) final_args;
                body = Lapply{ap_should_be_tailcall=false;
                              ap_loc=loc;
                              ap_func=(Lvar funct_var);
@@ -1102,7 +1105,7 @@ let rec close fenv cenv = function
   | Lstaticcatch(body, (i, vars), handler) ->
       let (ubody, _) = close fenv cenv body in
       let (uhandler, _) = close fenv cenv handler in
-      let vars = List.map (fun var -> VP.create var) vars in
+      let vars = List.map (fun (var, k) -> VP.create var, k) vars in
       (Ucatch(i, vars, ubody, uhandler), Value_unknown)
   | Ltrywith(body, id, handler) ->
       let (ubody, _) = close fenv cenv body in
@@ -1165,9 +1168,9 @@ and close_functions fenv cenv fun_defs =
     List.flatten
       (List.map
          (function
-           | (id, Lfunction{kind; params; body; attr; loc}) ->
+           | (id, Lfunction{kind; params; return; body; attr; loc}) ->
                Simplif.split_default_wrapper ~id ~kind ~params
-                 ~body ~attr ~loc
+                 ~body ~attr ~loc ~return
            | _ -> assert false
          )
          fun_defs)
@@ -1189,7 +1192,7 @@ and close_functions fenv cenv fun_defs =
   let uncurried_defs =
     List.map
       (function
-          (id, Lfunction{kind; params; body; loc}) ->
+          (id, Lfunction{kind; params; return; body; loc}) ->
             let label = Compilenv.make_symbol (Some (V.unique_name id)) in
             let arity = List.length params in
             let fundesc =
@@ -1199,20 +1202,20 @@ and close_functions fenv cenv fun_defs =
                fun_inline = None;
                fun_float_const_prop = !Clflags.float_const_prop } in
             let dbg = Debuginfo.from_location loc in
-            (id, params, body, fundesc, dbg)
+            (id, params, return, body, fundesc, dbg)
         | (_, _) -> fatal_error "Closure.close_functions")
       fun_defs in
   (* Build an approximate fenv for compiling the functions *)
   let fenv_rec =
     List.fold_right
-      (fun (id, _params, _body, fundesc, _dbg) fenv ->
+      (fun (id, _params, _return, _body, fundesc, _dbg) fenv ->
         V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv)
       uncurried_defs fenv in
   (* Determine the offsets of each function's closure in the shared block *)
   let env_pos = ref (-1) in
   let clos_offsets =
     List.map
-      (fun (_id, _params, _body, fundesc, _dbg) ->
+      (fun (_id, _params, _return, _body, fundesc, _dbg) ->
         let pos = !env_pos + 1 in
         env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
         pos)
@@ -1222,23 +1225,28 @@ and close_functions fenv cenv fun_defs =
      does not use its environment parameter is invalidated. *)
   let useless_env = ref initially_closed in
   (* Translate each function definition *)
-  let clos_fundef (id, params, body, fundesc, dbg) env_pos =
+  let clos_fundef (id, params, return, body, fundesc, dbg) env_pos =
     let env_param = V.create_local "env" in
     let cenv_fv =
       build_closure_env env_param (fv_pos - env_pos) fv in
     let cenv_body =
       List.fold_right2
-        (fun (id, _params, _body, _fundesc, _dbg) pos env ->
+        (fun (id, _params, _return, _body, _fundesc, _dbg) pos env ->
           V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
         uncurried_defs clos_offsets cenv_fv in
     let (ubody, approx) = close fenv_rec cenv_body body in
     if !useless_env && occurs_var env_param ubody then raise NotClosed;
-    let fun_params = if !useless_env then params else params @ [env_param] in
+    let fun_params =
+      if !useless_env
+      then params
+      else params @ [env_param, Pgenval]
+    in
     let f =
       {
         label  = fundesc.fun_label;
         arity  = fundesc.fun_arity;
-        params = List.map (fun var -> VP.create var) fun_params;
+        params = List.map (fun (var, kind) -> VP.create var, kind) fun_params;
+        return;
         body   = ubody;
         dbg;
         env = Some env_param;
@@ -1248,7 +1256,7 @@ and close_functions fenv cenv fun_defs =
        their wrapper functions) to be inlined *)
     let n =
       List.fold_left
-        (fun n id -> n + if V.name id = "*opt*" then 8 else 1)
+        (fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1)
         0
         fun_params
     in
@@ -1264,7 +1272,7 @@ and close_functions fenv cenv fun_defs =
       | Never_inline -> min_int
       | Unroll _ -> assert false
     in
-    let fun_params = List.map (fun var -> VP.create var) fun_params in
+    let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in
     if lambda_smaller ubody threshold
     then fundesc.fun_inline <- Some(fun_params, ubody);
 
@@ -1280,7 +1288,7 @@ and close_functions fenv cenv fun_defs =
          recompile *)
         Compilenv.backtrack snap; (* PR#6337 *)
         List.iter
-          (fun (_id, _params, _body, fundesc, _dbg) ->
+          (fun (_id, _params, _return, _body, fundesc, _dbg) ->
              fundesc.fun_closed <- false;
              fundesc.fun_inline <- None;
           )

asmcomp/cmmgen.ml

@@ -1969,7 +1969,7 @@ let rec transl env e =
       (* CR-someday mshinwell: consider how we can do better than
          [typ_val] when appropriate. *)
       let ids_with_types =
-        List.map (fun i -> (i, Cmm.typ_val)) ids in
+        List.map (fun (i, _) -> (i, Cmm.typ_val)) ids in
       ccatch(nfail, ids_with_types, transl env body, transl env handler)
   | Utrywith(body, exn, handler) ->
       Ctrywith(transl env body, exn, transl env handler)
@@ -2910,7 +2910,7 @@ let transl_function ~ppf_dump f =
       [ Reduce_code_size ]
   in
   Cfunction {fun_name = f.label;
-             fun_args = List.map (fun id -> (id, typ_val)) f.params;
+             fun_args = List.map (fun (id, _) -> (id, typ_val)) f.params;
              fun_body = cmm_body;
              fun_codegen_options;
              fun_dbg  = f.dbg}

asmcomp/flambda_to_clambda.ml

@@ -309,7 +309,7 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
     let env_handler, ids =
       List.fold_right (fun var (env, ids) ->
           let id, env = Env.add_fresh_ident env var in
-          env, VP.create id :: ids)
+          env, (VP.create id, Lambda.Pgenval) :: ids)
         vars (env, [])
     in
     Ucatch (Static_exception.to_int static_exn, ids,
@@ -527,7 +527,11 @@ and to_clambda_set_of_closures t env
     in
     { label = Compilenv.function_label closure_id;
       arity = Flambda_utils.function_arity function_decl;
-      params = List.map (fun var -> VP.create var) (params @ [env_var]);
+      params =
+        List.map
+          (fun var -> VP.create var, Lambda.Pgenval)
+          (params @ [env_var]);
+      return = Lambda.Pgenval;
       body = to_clambda t env_body function_decl.body;
       dbg = function_decl.dbg;
       env = Some env_var;
@@ -567,7 +571,8 @@ and to_clambda_closed_set_of_closures t env symbol
     in
     { label = Compilenv.function_label (Closure_id.wrap id);
       arity = Flambda_utils.function_arity function_decl;
-      params = List.map (fun var -> VP.create var) params;
+      params = List.map (fun var -> VP.create var, Lambda.Pgenval) params;
+      return = Lambda.Pgenval;
       body = to_clambda t env_body function_decl.body;
       dbg = function_decl.dbg;
       env = None;

asmcomp/printclambda.ml

@@ -52,17 +52,24 @@ let rec structured_constant ppf = function
       fprintf ppf ")"
   | Uconst_string s -> fprintf ppf "%S" s
   | Uconst_closure(clos, sym, fv) ->
-      let idents ppf =
-        List.iter (fprintf ppf "@ %a" VP.print) in
-      let one_fun ppf f =
-        fprintf ppf "(fun@ %s@ %d@ @[<2>%a@]@ @[<2>%a@])"
-          f.label f.arity idents f.params lam f.body in
       let funs ppf =
         List.iter (fprintf ppf "@ %a" one_fun) in
       let sconsts ppf scl =
         List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in
       fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv
 
+and one_fun ppf f =
+  let idents ppf =
+    List.iter
+      (fun (x, k) ->
+         fprintf ppf "@ %a%a"
+           VP.print x
+           Printlambda.value_kind k
+      )
+  in
+  fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])"
+    f.label (value_kind f.return) f.arity idents f.params lam f.body
+
 and phantom_defining_expr ppf = function
   | Uphantom_const const -> uconstant ppf const
   | Uphantom_var var -> Ident.print ppf var
@@ -103,13 +110,8 @@ and lam ppf = function
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
   | Uclosure(clos, fv) ->
-      let idents ppf =
-        List.iter (fprintf ppf "@ %a" VP.print) in
-      let one_fun ppf f =
-        fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])"
-          f.label f.arity idents f.params lam f.body in
       let funs ppf =
-        List.iter (fprintf ppf "@ %a" one_fun) in
+        List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in
       let lams ppf =
         List.iter (fprintf ppf "@ %a" lam) in
       fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
@@ -196,12 +198,15 @@ and lam ppf = function
   | Ucatch(i, vars, lbody, lhandler) ->
       fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
         lam lbody i
-        (fun ppf vars -> match vars with
+        (fun ppf vars ->
-          | [] -> ()
+           List.iter
-          | _ ->
+             (fun (x, k) ->
-              List.iter
+                fprintf ppf " %a%a"
-                (fun x -> fprintf ppf " %a" VP.print x)
+                 VP.print x
-                vars)
+                 Printlambda.value_kind k
+             )
+             vars
+        )
         vars
         lam lhandler
   | Utrywith(lbody, param, lhandler) ->

asmcomp/un_anf.ml

@@ -54,9 +54,10 @@ let ignore_primitive (_ : Lambda.primitive) = ()
 let ignore_string (_ : string) = ()
 let ignore_int_array (_ : int array) = ()
 let ignore_var_with_provenance (_ : VP.t) = ()
-let ignore_var_with_provenance_list (_ : VP.t list) = ()
+let ignore_params_with_value_kind (_ : (VP.t * Lambda.value_kind) list) = ()
 let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
 let ignore_meth_kind (_ : Lambda.meth_kind) = ()
+let ignore_value_kind (_ : Lambda.value_kind) = ()
 
 (* CR-soon mshinwell: check we aren't traversing function bodies more than
    once (need to analyse exactly what the calls are from Cmmgen into this
@@ -65,7 +66,7 @@ let ignore_meth_kind (_ : Lambda.meth_kind) = ()
 let closure_environment_var (ufunction:Clambda.ufunction) =
   (* The argument after the arity is the environment *)
   if List.length ufunction.params = ufunction.arity + 1 then
-    let env_var = List.nth ufunction.params ufunction.arity in
+    let (env_var, _) = List.nth ufunction.params ufunction.arity in
     assert (VP.name env_var = "env");
     Some env_var
   else
@@ -103,7 +104,7 @@ let make_var_info (clam : Clambda.ulambda) : var_info =
     | Uclosure (functions, captured_variables) ->
       List.iter loop captured_variables;
       List.iter (fun (
-        { Clambda. label; arity; params; body; dbg; env; } as clos) ->
+        { Clambda. label; arity; params; return; body; dbg; env; } as clos) ->
           (match closure_environment_var clos with
            | None -> ()
            | Some env_var ->
@@ -111,7 +112,8 @@ let make_var_info (clam : Clambda.ulambda) : var_info =
                V.Set.add (VP.var env_var) !environment_vars);
           ignore_function_label label;
           ignore_int arity;
-          ignore_var_with_provenance_list params;
+          ignore_params_with_value_kind params;
+          ignore_value_kind return;
           loop body;
           ignore_debuginfo dbg;
           ignore_var_option env)
@@ -156,7 +158,7 @@ let make_var_info (clam : Clambda.ulambda) : var_info =
       List.iter loop args
     | Ucatch (static_exn, vars, body, handler) ->
       ignore_int static_exn;
-      ignore_var_with_provenance_list vars;
+      ignore_params_with_value_kind vars;
       loop body;
       loop handler
     | Utrywith (body, var, handler) ->
@@ -276,10 +278,11 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) =
     | Uclosure (functions, captured_variables) ->
       ignore_ulambda_list captured_variables;
       (* Start a new let stack for speed. *)
-      List.iter (fun { Clambda. label; arity; params; body; dbg; env; } ->
+      List.iter (fun {Clambda. label; arity; params; return; body; dbg; env} ->
           ignore_function_label label;
           ignore_int arity;
-          ignore_var_with_provenance_list params;
+          ignore_params_with_value_kind params;
+          ignore_value_kind return;
           let_stack := [];
           loop body;
           let_stack := [];
@@ -358,7 +361,7 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) =
       examine_argument_list args
     | Ucatch (static_exn, vars, body, handler) ->
       ignore_int static_exn;
-      ignore_var_with_provenance_list vars;
+      ignore_params_with_value_kind vars;
       let_stack := [];
       loop body;
       let_stack := [];

bytecomp/bytegen.ml

@@ -520,7 +520,7 @@ let rec comp_expr env exp sz cont =
       let lbl = new_label() in
       let fv = Ident.Set.elements(free_variables exp) in
       let to_compile =
-        { params = params; body = body; label = lbl;
+        { params = List.map fst params; body = body; label = lbl;
           free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in
       Stack.push to_compile functions_to_compile;
       comp_args env (List.map (fun n -> Lvar n) fv) sz
@@ -542,8 +542,9 @@ let rec comp_expr env exp sz cont =
           | (_id, Lfunction{params; body}) :: rem ->
               let lbl = new_label() in
               let to_compile =
-                { params = params; body = body; label = lbl; free_vars = fv;
+                { params = List.map fst params; body = body; label = lbl;
-                  num_defs = ndecl; rec_vars = rec_idents; rec_pos = pos} in
+                  free_vars = fv; num_defs = ndecl; rec_vars = rec_idents;
+                  rec_pos = pos} in
               Stack.push to_compile functions_to_compile;
               lbl :: comp_fun (pos + 1) rem
           | _ -> assert false in
@@ -704,6 +705,7 @@ let rec comp_expr env exp sz cont =
   | Lprim(p, args, _) ->
       comp_args env args sz (comp_primitive p args :: cont)
   | Lstaticcatch (body, (i, vars) , handler) ->
+      let vars = List.map fst vars in
       let nvars = List.length vars in
       let branch1, cont1 = make_branch cont in
       let r =

bytecomp/lambda.ml

@@ -276,7 +276,7 @@ type lambda =
   | Lstringswitch of
       lambda * (string * lambda) list * lambda option * Location.t
   | Lstaticraise of int * lambda list
-  | Lstaticcatch of lambda * (int * Ident.t list) * lambda
+  | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda
   | Ltrywith of lambda * Ident.t * lambda
   | Lifthenelse of lambda * lambda * lambda
   | Lsequence of lambda * lambda
@@ -289,7 +289,8 @@ type lambda =
 
 and lfunction =
   { kind: function_kind;
-    params: Ident.t list;
+    params: (Ident.t * value_kind) list;
+    return: value_kind;
     body: lambda;
     attr: function_attribute; (* specified with [@inline] attribute *)
     loc: Location.t; }
@@ -508,7 +509,7 @@ let rec free_variables = function
       free_variables_list (free_variables fn) args
   | Lfunction{body; params} ->
       Ident.Set.diff (free_variables body)
-        (Ident.Set.of_list params)
+        (Ident.Set.of_list (List.map fst params))
   | Llet(_str, _k, id, arg, body) ->
       Ident.Set.union
         (free_variables arg)
@@ -544,7 +545,7 @@ let rec free_variables = function
       Ident.Set.union
         (Ident.Set.diff
            (free_variables handler)
-           (Ident.Set.of_list params))
+           (Ident.Set.of_list (List.map fst params)))
         (free_variables body)
   | Ltrywith(body, param, handler) ->
       Ident.Set.union
@@ -647,7 +648,7 @@ let rec make_sequence fn = function
 let subst update_env s lam =
   let rec subst s lam =
     let remove_list l s =
-      List.fold_left (fun s id -> Ident.Map.remove id s) s l
+      List.fold_left (fun s (id, _kind) -> Ident.Map.remove id s) s l
     in
     let module M = Ident.Map in
     match lam with
@@ -657,9 +658,13 @@ let subst update_env s lam =
     | Lapply ap ->
         Lapply{ap with ap_func = subst s ap.ap_func;
                       ap_args = subst_list s ap.ap_args}
-    | Lfunction{kind; params; body; attr; loc} ->
+    | Lfunction lf ->
-        let s = List.fold_right Ident.Map.remove params s in
+        let s =
-        Lfunction{kind; params; body = subst s body; attr; loc}
+          List.fold_right
+            (fun (id, _) s -> Ident.Map.remove id s)
+            lf.params s
+        in
+        Lfunction {lf with body = subst s lf.body}
     | Llet(str, k, id, arg, body) ->
         Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body)
     | Lletrec(decl, body) ->
@@ -738,8 +743,8 @@ let rec map f lam =
           ap_inlined;
           ap_specialised;
         }
-    | Lfunction { kind; params; body; attr; loc; } ->
+    | Lfunction { kind; params; return; body; attr; loc; } ->
-        Lfunction { kind; params; body = map f body; attr; loc; }
+        Lfunction { kind; params; return; body = map f body; attr; loc; }
     | Llet (str, k, v, e1, e2) ->
         Llet (str, k, v, map f e1, map f e2)
     | Lletrec (idel, e2) ->
@@ -788,10 +793,13 @@ let rec map f lam =
 
 (* To let-bind expressions to variables *)
 
-let bind str var exp body =
+let bind_with_value_kind str (var, kind) exp body =
   match exp with
     Lvar var' when Ident.same var var' -> body
-  | _ -> Llet(str, Pgenval, var, exp, body)
+  | _ -> Llet(str, kind, var, exp, body)
+
+let bind str var exp body =
+  bind_with_value_kind str (var, Pgenval) exp body
 
 let negate_integer_comparison = function
   | Ceq -> Cne

bytecomp/lambda.mli

@@ -260,7 +260,7 @@ type lambda =
   | Lstringswitch of
       lambda * (string * lambda) list * lambda option * Location.t
   | Lstaticraise of int * lambda list
-  | Lstaticcatch of lambda * (int * Ident.t list) * lambda
+  | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda
   | Ltrywith of lambda * Ident.t * lambda
   | Lifthenelse of lambda * lambda * lambda
   | Lsequence of lambda * lambda
@@ -273,7 +273,8 @@ type lambda =
 
 and lfunction =
   { kind: function_kind;
-    params: Ident.t list;
+    params: (Ident.t * value_kind) list;
+    return: value_kind;
     body: lambda;
     attr: function_attribute; (* specified with [@inline] attribute *)
     loc : Location.t; }
@@ -362,6 +363,8 @@ val rename : Ident.t Ident.Map.t -> lambda -> lambda
 
 val map : (lambda -> lambda) -> lambda -> lambda
 val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
+val bind_with_value_kind:
+  let_kind -> (Ident.t * value_kind) -> lambda -> lambda -> lambda
 
 val negate_integer_comparison : integer_comparison -> integer_comparison
 val swap_integer_comparison : integer_comparison -> integer_comparison

bytecomp/matching.ml

@@ -392,7 +392,9 @@ type pattern_matching =
 
 type pm_or_compiled =
   {body : pattern_matching ;
-   handlers : (matrix * int * Ident.t list * pattern_matching) list ;
+   handlers :
+     (matrix * int * (Ident.t * Lambda.value_kind) list * pattern_matching)
+       list;
    or_matrix : matrix ; }
 
 type pm_half_compiled =
@@ -596,12 +598,15 @@ let simplify_cases args cls = match args with
       | ((pat :: patl, action) as cl) :: rem ->
           begin match pat.pat_desc with
           | Tpat_var (id, _) ->
-              (omega :: patl, bind Alias id arg action) ::
+              let k = Typeopt.value_kind pat.pat_env pat.pat_type in
+              (omega :: patl, bind_with_value_kind Alias (id, k) arg action) ::
               simplify rem
           | Tpat_any ->
               cl :: simplify rem
           | Tpat_alias(p, id,_) ->
-              simplify ((p :: patl, bind Alias id arg action) :: rem)
+              let k = Typeopt.value_kind pat.pat_env pat.pat_type in
+              simplify ((p :: patl,
+                         bind_with_value_kind Alias (id, k) arg action) :: rem)
           | Tpat_record ([],_) ->
               (omega :: patl, action)::
               simplify rem
@@ -664,25 +669,6 @@ let default_compat p def =
     def []
 
 (* Or-pattern expansion, variables are a complication w.r.t. the article *)
-let rec extract_vars r p = match p.pat_desc with
-| Tpat_var (id, _) -> Ident.Set.add id r
-| Tpat_alias (p, id,_ ) ->
-    extract_vars (Ident.Set.add id r) p
-| Tpat_tuple pats ->
-    List.fold_left extract_vars r pats
-| Tpat_record (lpats,_) ->
-    List.fold_left
-      (fun r (_, _, p) -> extract_vars r p)
-      r lpats
-| Tpat_construct (_, _, pats) ->
-    List.fold_left extract_vars r pats
-| Tpat_array pats ->
-    List.fold_left extract_vars r pats
-| Tpat_variant (_,Some p, _) -> extract_vars r p
-| Tpat_lazy p -> extract_vars r p
-| Tpat_or (p,_,_) -> extract_vars r p
-| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r
-| Tpat_exception _ -> assert false
 
 exception Cannot_flatten
 
@@ -834,8 +820,8 @@ let insert_or_append p ps act ors no =
         if is_or q then begin
           if may_compat p q then
             if
-              Ident.Set.is_empty (extract_vars Ident.Set.empty p) &&
+              Typedtree.pat_bound_idents p = [] &&
-              Ident.Set.is_empty (extract_vars Ident.Set.empty q) &&
+              Typedtree.pat_bound_idents q = [] &&
               equiv_pat p q
             then (* attempt insert, for equivalent orpats with no variables *)
               let _, not_e = get_equiv q rem in
@@ -1129,12 +1115,13 @@ and precompile_or argo cls ors args def k = match ors with
                   | _ -> assert false)
                 others ;
               args = (match args with _::r -> r | _ -> assert false) ;
-              default = default_compat orp def} in
+             default = default_compat orp def} in
+          let pm_fv = pm_free_variables orpm in
           let vars =
-            Ident.Set.elements
+            Typedtree.pat_bound_idents_full orp
-              (Ident.Set.inter
+            |> List.filter (fun (id, _, _) -> Ident.Set.mem id pm_fv)
-                 (extract_vars Ident.Set.empty orp)
+            |> List.map (fun (id,_,ty) -> id,Typeopt.value_kind orp.pat_env ty)
-                 (pm_free_variables orpm)) in
+          in
           let or_num = next_raise_count () in
           let new_patl = Parmatch.omega_list patl in
 
@@ -1144,7 +1131,7 @@ and precompile_or argo cls ors args def k = match ors with
 
           let body,handlers = do_cases rem in
           explode_or_pat
-            argo new_patl mk_new_action body vars [] orp,
+            argo new_patl mk_new_action body (List.map fst vars) [] orp,
           let mat = [[orp]] in
           ((mat, or_num, vars , orpm):: handlers)
       | cl::rem ->
@@ -2573,7 +2560,8 @@ let compile_orhandlers compile_fun lambda1 total1 ctx to_catch =
           match raw_action r with
           | Lstaticraise (j,args) ->
               if i=j then
-                List.fold_right2 (bind Alias) vars args handler_i,
+                List.fold_right2 (bind_with_value_kind Alias)
+                  vars args handler_i,
                 jumps_map (ctx_rshift_num (ncols mat)) total_i
               else
                 do_rec r total_r rem
@@ -3084,9 +3072,14 @@ let for_let loc param pat body =
   | _ ->
       let opt = ref false in
       let nraise = next_raise_count () in
-      let catch_ids = pat_bound_idents pat in
+      let catch_ids = pat_bound_idents_full pat in
-      let bind = map_return (assign_pat opt nraise catch_ids loc pat) param in
+      let ids_with_kinds =
-      if !opt then Lstaticcatch(bind, (nraise, catch_ids), body)
+        List.map (fun (id, _, typ) -> id, Typeopt.value_kind pat.pat_env typ)
+          catch_ids
+      in
+      let ids = List.map (fun (id, _, _) -> id) catch_ids in
+      let bind = map_return (assign_pat opt nraise ids loc pat) param in
+      if !opt then Lstaticcatch(bind, (nraise, ids_with_kinds), body)
       else simple_for_let loc param pat body
 
 (* Handling of tupled functions and matchings *)

bytecomp/printlambda.ml

@@ -54,11 +54,17 @@ let boxed_integer_name = function
   | Pint32 -> "int32"
   | Pint64 -> "int64"
 
-let value_kind = function
+let value_kind ppf = function
-  | Pgenval -> ""
+  | Pgenval -> ()
-  | Pintval -> "[int]"
+  | Pintval -> fprintf ppf "[int]"
-  | Pfloatval -> "[float]"
+  | Pfloatval -> fprintf ppf "[float]"
-  | Pboxedintval bi -> Printf.sprintf "[%s]" (boxed_integer_name bi)
+  | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
+
+let return_kind ppf = function
+  | Pgenval -> ()
+  | Pintval -> fprintf ppf ": int@ "
+  | Pfloatval -> fprintf ppf ": float@ "
+  | Pboxedintval bi -> fprintf ppf ": %s@ " (boxed_integer_name bi)
 
 let field_kind = function
   | Pgenval -> "*"
@@ -483,34 +489,36 @@ let rec lam ppf = function
         apply_tailcall_attribute ap.ap_should_be_tailcall
         apply_inlined_attribute ap.ap_inlined
         apply_specialised_attribute ap.ap_specialised
-  | Lfunction{kind; params; body; attr} ->
+  | Lfunction{kind; params; return; body; attr} ->
       let pr_params ppf params =
         match kind with
         | Curried ->
-            List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params
+            List.iter (fun (param, k) ->
+                fprintf ppf "@ %a%a" Ident.print param value_kind k) params
         | Tupled ->
             fprintf ppf " (";
             let first = ref true in
             List.iter
-              (fun param ->
+              (fun (param, k) ->
                 if !first then first := false else fprintf ppf ",@ ";
-                Ident.print ppf param)
+                Ident.print ppf param;
+                value_kind ppf k)
               params;
             fprintf ppf ")" in
-      fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params
+      fprintf ppf "@[<2>(function%a@ %a%a%a)@]" pr_params params
-        function_attribute attr lam body
+        function_attribute attr return_kind return lam body
   | Llet(str, k, id, arg, body) ->
       let kind = function
           Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v"
       in
       let rec letbody = function
         | Llet(str, k, id, arg, body) ->
-            fprintf ppf "@ @[<2>%a =%s%s@ %a@]"
+            fprintf ppf "@ @[<2>%a =%s%a@ %a@]"
-              Ident.print id (kind str) (value_kind k) lam arg;
+              Ident.print id (kind str) value_kind k lam arg;
             letbody body
         | expr -> expr in
-      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s%s@ %a@]"
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s%a@ %a@]"
-        Ident.print id (kind str) (value_kind k) lam arg;
+        Ident.print id (kind str) value_kind k lam arg;
       let expr = letbody body in
       fprintf ppf ")@]@ %a)@]" lam expr
   | Lletrec(id_arg_list, body) ->
@@ -573,12 +581,11 @@ let rec lam ppf = function
   | Lstaticcatch(lbody, (i, vars), lhandler) ->
       fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
         lam lbody i
-        (fun ppf vars -> match vars with
+        (fun ppf vars ->
-          | [] -> ()
+           List.iter
-          | _ ->
+             (fun (x, k) -> fprintf ppf " %a%a" Ident.print x value_kind k)
-              List.iter
+             vars
-                (fun x -> fprintf ppf " %a" Ident.print x)
+        )
-                vars)
         vars
         lam lhandler
   | Ltrywith(lbody, param, lhandler) ->

bytecomp/printlambda.mli

@@ -22,4 +22,5 @@ val lambda: formatter -> lambda -> unit
 val program: formatter -> program -> unit
 val primitive: formatter -> primitive -> unit
 val name_of_primitive : primitive -> string
-val value_kind : value_kind -> string
+val value_kind : formatter -> value_kind -> unit
+val array_kind : array_kind -> string

bytecomp/simplif.ml

@@ -206,8 +206,8 @@ let simplify_exits lam =
   | Lapply ap ->
       Lapply{ap with ap_func = simplif ap.ap_func;
                      ap_args = List.map simplif ap.ap_args}
-  | Lfunction{kind; params; body = l; attr; loc} ->
+  | Lfunction{kind; params; return; body = l; attr; loc} ->
-     Lfunction{kind; params; body = simplif l; attr; loc}
+     Lfunction{kind; params; return; body = simplif l; attr; loc}
   | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2)
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
@@ -263,10 +263,14 @@ let simplify_exits lam =
       let ls = List.map simplif ls in
       begin try
         let xs,handler =  Hashtbl.find subst i in
-        let ys = List.map Ident.rename xs in
+        let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in
-        let env = List.fold_right2 Ident.Map.add xs ys Ident.Map.empty in
+        let env =
+          List.fold_right2
+            (fun (x, _) (y, _) env -> Ident.Map.add x y env)
+            xs ys Ident.Map.empty
+        in
         List.fold_right2
-          (fun y l r -> Llet (Alias, Pgenval, y, l, r))
+          (fun (y, kind) l r -> Llet (Alias, kind, y, l, r))
           ys ls (Lambda.rename env handler)
       with
       | Not_found -> Lstaticraise (i,ls)
@@ -314,7 +318,7 @@ let simplify_exits lam =
 *)
 
 let beta_reduce params body args =
-  List.fold_left2 (fun l param arg -> Llet(Strict, Pgenval, param, arg, l))
+  List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l))
                   body params args
 
 (* Simplification of lets *)
@@ -470,13 +474,18 @@ let simplify_lets lam =
       simplif (beta_reduce params body args)
   | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func;
                                  ap_args = List.map simplif ap.ap_args}
-  | Lfunction{kind; params; body = l; attr; loc} ->
+  | Lfunction{kind; params; return=return1; body = l; attr; loc} ->
       begin match simplif l with
-        Lfunction{kind=Curried; params=params'; body; attr; loc}
+        Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc}
         when kind = Curried && optimize ->
-          Lfunction{kind; params = params @ params'; body; attr; loc}
+          (* The return type is the type of the value returned after
+             applying all the parameters to the function. The return
+             type of the merged function taking [params @ params'] as
+             parameters is the type returned after applying [params']. *)
+          let return = return2 in
+          Lfunction{kind; params = params @ params'; return; body; attr; loc}
       | body ->
-          Lfunction{kind; params; body; attr; loc}
+          Lfunction{kind; params; return = return1; body; attr; loc}
       end
   | Llet(_str, _k, v, Lvar w, l2) when optimize ->
       Hashtbl.add subst v (simplif (Lvar w));
@@ -648,10 +657,10 @@ and list_emit_tail_infos is_tail =
    'Some' constructor, only to deconstruct it immediately in the
    function's body. *)
 
-let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc =
+let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
   let rec aux map = function
     | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
-        Ident.name optparam = "*opt*" && List.mem optparam params
+        Ident.name optparam = "*opt*" && List.mem_assoc optparam params
           && not (List.mem_assoc optparam map)
       ->
         let wrapper_body, inner = aux ((optparam, id) :: map) rest in
@@ -665,7 +674,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc =
 
         let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in
         let map_param p = try List.assoc p map with Not_found -> p in
-        let args = List.map (fun p -> Lvar (map_param p)) params in
+        let args = List.map (fun (p, _) -> Lvar (map_param p)) params in
         let wrapper_body =
           Lapply {
             ap_func = Lvar inner_id;
@@ -676,7 +685,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc =
             ap_specialised = Default_specialise;
           }
         in
-        let inner_params = List.map map_param params in
+        let inner_params = List.map map_param (List.map fst params) in
         let new_ids = List.map Ident.rename inner_params in
         let subst =
           List.fold_left2 (fun s id new_id ->
@@ -685,16 +694,18 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc =
         in
         let body = Lambda.rename subst body in
         let inner_fun =
-          Lfunction { kind = Curried; params = new_ids; body; attr; loc; }
+          Lfunction { kind = Curried;
+            params = List.map (fun id -> id, Pgenval) new_ids;
+            return; body; attr; loc; }
         in
         (wrapper_body, (inner_id, inner_fun))
   in
   try
     let body, inner = aux [] body in
     let attr = default_stub_attribute in
-    [(fun_id, Lfunction{kind; params; body; attr; loc}); inner]
+    [(fun_id, Lfunction{kind; params; return; body; attr; loc}); inner]
   with Exit ->
-    [(fun_id, Lfunction{kind; params; body; attr; loc})]
+    [(fun_id, Lfunction{kind; params; return; body; attr; loc})]
 
 module Hooks = Misc.MakeHooks(struct
     type t = lambda

bytecomp/simplif.mli

@@ -32,7 +32,8 @@ val simplify_lambda: string -> lambda -> lambda
 val split_default_wrapper
    : id:Ident.t
   -> kind:function_kind
-  -> params:Ident.t list
+  -> params:(Ident.t * Lambda.value_kind) list
+  -> return:Lambda.value_kind
   -> body:lambda
   -> attr:function_attribute
   -> loc:Location.t

bytecomp/translclass.ml

@@ -30,10 +30,12 @@ let lfunction params body =
   if params = [] then body else
   match body with
   | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} ->
-      Lfunction {kind = Curried; params = params @ params'; body = body'; attr;
+      Lfunction {kind = Curried; params = params @ params';
+                 return = Pgenval;
+                 body = body'; attr;
                  loc}
   |  _ ->
-      Lfunction {kind = Curried; params;
+      Lfunction {kind = Curried; params; return = Pgenval;
                  body;
                  attr = default_function_attribute;
                  loc = Location.none}
@@ -170,7 +172,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
       (inh_init,
        let build params rem =
          let param = name_pattern "param" pat in
-         Lfunction {kind = Curried; params = param::params;
+         Lfunction {kind = Curried; params = (param, Pgenval)::params;
+                    return = Pgenval;
                     attr = default_function_attribute;
                     loc = pat.pat_loc;
                     body = Matching.for_function
@@ -206,8 +209,8 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
       let ((_,inh_init), obj_init) =
         build_object_init cl_table obj params (envs,[]) copy_env cl in
       let obj_init =
-        if ids = [] then obj_init else lfunction [self] obj_init in
+        if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in
-      (inh_init, lfunction [env] (subst_env env inh_init obj_init))
+      (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init))
 
 
 let bind_method tbl lab id cl_init =
@@ -421,7 +424,8 @@ let rec transl_class_rebind obj_init cl vf =
       let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
       let build params rem =
         let param = name_pattern "param" pat in
-        Lfunction {kind = Curried; params = param::params;
+        Lfunction {kind = Curried; params = (param, Pgenval)::params;
+                   return = Pgenval;
                    attr = default_function_attribute;
                    loc = pat.pat_loc;
                    body = Matching.for_function
@@ -450,7 +454,7 @@ let rec transl_class_rebind obj_init cl vf =
   | Tcl_open (_, _, _, _, cl) ->
       transl_class_rebind obj_init cl vf
 
-let rec transl_class_rebind_0 self obj_init cl vf =
+let rec transl_class_rebind_0 (self:Ident.t) obj_init cl vf =
   match cl.cl_desc with
     Tcl_let (rec_flag, defs, _vals, cl) ->
       let path, path_lam, obj_init =
@@ -459,7 +463,7 @@ let rec transl_class_rebind_0 self obj_init cl vf =
       (path, path_lam, Translcore.transl_let rec_flag defs obj_init)
   | _ ->
       let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
-      (path, path_lam, lfunction [self] obj_init)
+      (path, path_lam, lfunction [self, Pgenval] obj_init)
 
 let transl_class_rebind cl vf =
   try
@@ -474,7 +478,7 @@ let transl_class_rebind cl vf =
               ap_specialised=Default_specialise}
     in
     let _, path_lam, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
-    let id = (obj_init' = lfunction [self] obj_init0) in
+    let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in
     if id then path_lam else
 
     let cla = Ident.create_local "class"
@@ -483,15 +487,15 @@ let transl_class_rebind cl vf =
     and table = Ident.create_local "table"
     and envs = Ident.create_local "envs" in
     Llet(
-    Strict, Pgenval, new_init, lfunction [obj_init] obj_init',
+    Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init',
     Llet(
     Alias, Pgenval, cla, path_lam,
     Lprim(Pmakeblock(0, Immutable, None),
           [mkappl(Lvar new_init, [lfield cla 0]);
-           lfunction [table]
+           lfunction [table, Pgenval]
              (Llet(Strict, Pgenval, env_init,
                    mkappl(lfield cla 1, [Lvar table]),
-                   lfunction [envs]
+                   lfunction [envs, Pgenval]
                      (mkappl(Lvar new_init,
                              [mkappl(Lvar env_init, [Lvar envs])]))));
            lfield cla 2;
@@ -552,7 +556,7 @@ let rec builtin_meths self env env2 body =
   | Lsend(Cached, met, arg, [_;_], _) ->
       let s, args = conv arg in
       ("send_"^s, met :: args)
-  | Lfunction {kind = Curried; params = [x]; body} ->
+  | Lfunction {kind = Curried; params = [x, _]; body} ->
       let rec enter self = function
         | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _)
           when Ident.same x x' && List.mem s self ->
@@ -635,13 +639,13 @@ let free_methods l =
         fv := Ident.Set.add meth !fv
     | Lsend _ -> ()
     | Lfunction{params} ->
-        List.iter (fun param -> fv := Ident.Set.remove param !fv) params
+        List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params
     | Llet(_str, _k, id, _arg, _body) ->
         fv := Ident.Set.remove id !fv
     | Lletrec(decl, _body) ->
         List.iter (fun (id, _exp) -> fv := Ident.Set.remove id !fv) decl
     | Lstaticcatch(_e1, (_,vars), _e2) ->
-        List.iter (fun id -> fv := Ident.Set.remove id !fv) vars
+        List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars
     | Ltrywith(_e1, exn, _e2) ->
         fv := Ident.Set.remove exn !fv
     | Lfor(v, _e1, _e2, _dir, _e3) ->
@@ -691,7 +695,7 @@ let transl_class ids cl_id pub_meths cl vflag =
   let new_ids_meths = ref [] in
   let no_env_update _ _ env = env in
   let msubst arr = function
-      Lfunction {kind = Curried; params = self :: args; body} ->
+      Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} ->
         let env = Ident.create_local "env" in
         let body' =
           if new_ids = [] then body else
@@ -702,7 +706,7 @@ let transl_class ids cl_id pub_meths cl vflag =
           if not arr || !Clflags.debug then raise Not_found;
           builtin_meths [self] env env2 (lfunction args body')
         with Not_found ->
-          [lfunction (self :: args)
+          [lfunction ((self, Pgenval) :: args)
              (if not (Ident.Set.mem env (free_variables body')) then body' else
               Llet(Alias, Pgenval, env,
                    Lprim(Pfield_computed,
@@ -769,7 +773,8 @@ let transl_class ids cl_id pub_meths cl vflag =
     let cl_init = llets (Lfunction{kind = Curried;
                                    attr = default_function_attribute;
                                    loc = Location.none;
-                                   params = [cla]; body = cl_init}) in
+                                   return = Pgenval;
+                                   params = [cla, Pgenval]; body = cl_init}) in
     Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
   and lbody fv =
     if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then
@@ -790,7 +795,8 @@ let transl_class ids cl_id pub_meths cl vflag =
           [lambda_unit; Lfunction{kind = Curried;
                                   attr = default_function_attribute;
                                   loc = Location.none;
-                                  params = [cla]; body = cl_init};
+                                  return = Pgenval;
+                                  params = [cla, Pgenval]; body = cl_init};
            lambda_unit; lenvs],
          Location.none)
   in
@@ -842,7 +848,8 @@ let transl_class ids cl_id pub_meths cl vflag =
   in
   let lclass lam =
     Llet(Strict, Pgenval, class_init,
-         Lfunction{kind = Curried; params = [cla];
+         Lfunction{kind = Curried; params = [cla, Pgenval];
+                   return = Pgenval;
                    attr = default_function_attribute;
                    loc = Location.none;
                    body = def_ids cla cl_init}, lam)
@@ -863,9 +870,17 @@ let transl_class ids cl_id pub_meths cl vflag =
             Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
                       lset cached 0 (Lvar env_init))))
   and lclass_virt () =
-    lset cached 0 (Lfunction{kind = Curried; attr = default_function_attribute;
+    lset cached 0
-                             loc = Location.none;
+      (Lfunction
-                             params = [cla]; body = def_ids cla cl_init})
+         {
+           kind = Curried;
+           attr = default_function_attribute;
+           loc = Location.none;
+           return = Pgenval;
+           params = [cla, Pgenval];
+           body = def_ids cla cl_init;
+         }
+      )
   in
   let lupdate_cache =
     if ids = [] then ldirect () else

bytecomp/translcore.ml

@@ -222,12 +222,13 @@ and transl_exp0 e =
   | Texp_let(rec_flag, pat_expr_list, body) ->
       transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
   | Texp_function { arg_label = _; param; cases; partial; } ->
-      let ((kind, params), body) =
+      let ((kind, params, return), body) =
         event_function e
           (function repr ->
             let pl = push_defaults e.exp_loc [] cases partial in
-            transl_function e.exp_loc !Clflags.native_code repr partial
+            let return_kind = function_return_value_kind e.exp_env e.exp_type in
-              param pl)
+            transl_function e.exp_loc return_kind !Clflags.native_code repr
+              partial param pl)
       in
       let attr = {
         default_function_attribute with
@@ -236,7 +237,7 @@ and transl_exp0 e =
       }
       in
       let loc = e.exp_loc in
-      Lfunction{kind; params; body; attr; loc}
+      Lfunction{kind; params; return; body; attr; loc}
   | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
                 exp_type = prim_type } as funct, oargs)
     when List.length oargs >= p.prim_arity
@@ -518,7 +519,8 @@ and transl_exp0 e =
       | `Other ->
          (* other cases compile to a lazy block holding a function *)
          let fn = Lfunction {kind = Curried;
-                             params= [Ident.create_local "param"];
+                             params= [Ident.create_local "param", Pgenval];
+                             return = Pgenval;
                              attr = default_function_attribute;
                              loc = e.exp_loc;
                              body = transl_exp e} in
@@ -620,15 +622,22 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
         and id_arg = Ident.create_local "param" in
         let body =
           match build_apply handle ((Lvar id_arg, optional)::args') l with
-            Lfunction{kind = Curried; params = ids; body = lam; attr; loc} ->
+            Lfunction{kind = Curried; params = ids; return;
-              Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr;
+                      body = lam; attr; loc} ->
+              Lfunction{kind = Curried;
+                        params = (id_arg, Pgenval)::ids;
+                        return;
+                        body = lam; attr;
                         loc}
-          | Levent(Lfunction{kind = Curried; params = ids;
+          | Levent(Lfunction{kind = Curried; params = ids; return;
                              body = lam; attr; loc}, _) ->
-              Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr;
+              Lfunction{kind = Curried; params = (id_arg, Pgenval)::ids;
+                        return;
+                        body = lam; attr;
                         loc}
           | lam ->
-              Lfunction{kind = Curried; params = [id_arg]; body = lam;
+              Lfunction{kind = Curried; params = [id_arg, Pgenval];
+                        return = Pgenval; body = lam;
                         attr = default_stub_attribute; loc = loc}
         in
         List.fold_left
@@ -644,15 +653,18 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
                                 sargs)
      : Lambda.lambda)
 
-and transl_function loc untuplify_fn repr partial param cases =
+and transl_function loc return untuplify_fn repr partial (param:Ident.t) cases =
   match cases with
     [{c_lhs=pat; c_guard=None;
       c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases;
-        partial = partial'; }} as exp}]
+        partial = partial'; }; exp_env; exp_type} as exp}]
     when Parmatch.inactive ~partial pat ->
-      let ((_, params), body) =
+      let kind = value_kind pat.pat_env pat.pat_type in
-        transl_function exp.exp_loc false repr partial' param' cases in
+      let return_kind = function_return_value_kind exp_env exp_type in
-      ((Curried, param :: params),
+      let ((_, params, return), body) =
+        transl_function exp.exp_loc return_kind false repr partial' param' cases
+      in
+      ((Curried, (param, kind) :: params, return),
        Matching.for_function loc None (Lvar param) [pat, body] partial)
   | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn ->
       begin try
@@ -662,17 +674,50 @@ and transl_function loc untuplify_fn repr partial param cases =
             (fun {c_lhs; c_guard; c_rhs} ->
               (Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
             cases in
-        let params = List.map (fun _ -> Ident.create_local "param") pl in
+        let kinds =
-        ((Tupled, params),
+          (* All the patterns might not share the same types. We must take the
+             union of the patterns types *)
+          match pats_expr_list with
+          | [] -> assert false
+          | (pats, _, _) :: cases ->
+              let first_case_kinds =
+                List.map (fun pat -> value_kind pat.pat_env pat.pat_type) pats
+              in
+              List.fold_left
+                (fun kinds (pats, _, _) ->
+                   List.map2 (fun kind pat ->
+                       value_kind_union kind
+                         (value_kind pat.pat_env pat.pat_type))
+                     kinds pats)
+                first_case_kinds cases
+        in
+        let tparams =
+          List.map (fun kind -> Ident.create_local "param", kind) kinds
+        in
+        let params = List.map fst tparams in
+        ((Tupled, tparams, return),
          Matching.for_tupled_function loc params
            (transl_tupled_cases pats_expr_list) partial)
       with Matching.Cannot_flatten ->
-        ((Curried, [param]),
+        ((Curried, [param, Pgenval], return),
          Matching.for_function loc repr (Lvar param)
            (transl_cases cases) partial)
       end
-  | _ ->
+  | {c_lhs=pat} :: other_cases ->
-      ((Curried, [param]),
+      let kind =
+        (* All the patterns might not share the same types. We must take the
+           union of the patterns types *)
+        List.fold_left (fun k {c_lhs=pat} ->
+            Typeopt.value_kind_union k
+              (value_kind pat.pat_env pat.pat_type))
+          (value_kind pat.pat_env pat.pat_type) other_cases
+      in
+      ((Curried, [param, kind], return),
+       Matching.for_function loc repr (Lvar param)
+         (transl_cases cases) partial)
+  | [] ->
+      (* With Camlp4, a pattern matching might be empty *)
+      ((Curried, [param, Pgenval], return),
        Matching.for_function loc repr (Lvar param)
          (transl_cases cases) partial)
 
@@ -840,7 +885,12 @@ and transl_match e arg pat_expr_list partial =
         in
         (* Simplif doesn't like it if binders are not uniq, so we make sure to
            use different names in the value and the exception branches. *)
-        let ids  = Typedtree.pat_bound_idents pv in
+        let ids_full = Typedtree.pat_bound_idents_full pv in
+        let ids = List.map (fun (id, _, _) -> id) ids_full in
+        let ids_kinds =
+          List.map (fun (id, _, ty) -> id, Typeopt.value_kind pv.pat_env ty)
+            ids_full
+        in
         let vids = List.map Ident.rename ids in
         let pv = alpha_pat (List.combine ids vids) pv in
         (* Also register the names of the exception so Re-raise happens. *)
@@ -853,7 +903,7 @@ and transl_match e arg pat_expr_list partial =
         in
         (pv, static_raise vids) :: val_cases,
         (pe, static_raise ids) :: exn_cases,
-        (lbl, ids, rhs) :: static_handlers
+        (lbl, ids_kinds, rhs) :: static_handlers
   in
   let val_cases, exn_cases, static_handlers =
     let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in
@@ -874,17 +924,25 @@ and transl_match e arg pat_expr_list partial =
       assert (static_handlers = []);
       Matching.for_multiple_match e.exp_loc (transl_list argl) val_cases partial
     | {exp_desc = Texp_tuple argl}, _ :: _ ->
-      let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in
+        let val_ids =
-      let lvars = List.map (fun id -> Lvar id) val_ids in
+          List.map
-      static_catch (transl_list argl) val_ids
+            (fun arg ->
-        (Matching.for_multiple_match e.exp_loc lvars val_cases partial)
+               Typecore.name_pattern "val" [],
+               Typeopt.value_kind arg.exp_env arg.exp_type
+            )
+            argl
+        in
+        let lvars = List.map (fun (id, _) -> Lvar id) val_ids in
+        static_catch (transl_list argl) val_ids
+          (Matching.for_multiple_match e.exp_loc lvars val_cases partial)
     | arg, [] ->
       assert (static_handlers = []);
       Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial
     | arg, _ :: _ ->
-      let val_id = Typecore.name_cases "val" pat_expr_list in
+        let val_id = Typecore.name_cases "val" pat_expr_list in
-      static_catch [transl_exp arg] [val_id]
+        let k = Typeopt.value_kind arg.exp_env arg.exp_type in
-        (Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial)
+        static_catch [transl_exp arg] [val_id, k]
+          (Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial)
   in
   List.fold_left (fun body (static_exception_id, val_ids, handler) ->
     Lstaticcatch (body, (static_exception_id, val_ids), handler)

bytecomp/translmod.ml

@@ -83,7 +83,7 @@ let rec apply_coercion loc strict restr arg =
   | Tcoerce_functor(cc_arg, cc_res) ->
       let param = Ident.create_local "funarg" in
       let carg = apply_coercion loc Alias cc_arg (Lvar param) in
-      apply_coercion_result loc strict arg [param] [carg] cc_res
+      apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res
   | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
       Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None
   | Tcoerce_alias (env, path, cc) ->
@@ -100,22 +100,27 @@ and apply_coercion_result loc strict funct params args cc_res =
     let param = Ident.create_local "funarg" in
     let arg = apply_coercion loc Alias cc_arg (Lvar param) in
     apply_coercion_result loc strict funct
-      (param :: params) (arg :: args) cc_res
+      ((param, Pgenval) :: params) (arg :: args) cc_res
   | _ ->
-    name_lambda strict funct (fun id ->
+      name_lambda strict funct
-      Lfunction{kind = Curried; params = List.rev params;
+        (fun id ->
-                attr = { default_function_attribute with
+           Lfunction
-                         is_a_functor = true;
+             {
-                         stub = true; };
+               kind = Curried;
-                loc = loc;
+               params = List.rev params;
-                body = apply_coercion
+               return = Pgenval;
-                         loc Strict cc_res
+               attr = { default_function_attribute with
-                         (Lapply{ap_should_be_tailcall=false;
+                        is_a_functor = true;
-                                 ap_loc=loc;
+                        stub = true; };
-                                 ap_func=Lvar id;
+               loc = loc;
-                                 ap_args=List.rev args;
+               body = apply_coercion
-                                 ap_inlined=Default_inline;
+                   loc Strict cc_res
-                                 ap_specialised=Default_specialise})})
+                   (Lapply{ap_should_be_tailcall=false;
+                           ap_loc=loc;
+                           ap_func=Lvar id;
+                           ap_args=List.rev args;
+                           ap_inlined=Default_inline;
+                           ap_specialised=Default_specialise})})
 
 and wrap_id_pos_list loc id_pos_list get_field lam =
   let fv = free_variables lam in
@@ -443,7 +448,7 @@ let rec compile_functor mexp coercion root_path loc =
     List.fold_left (fun (params, body) (param, loc, arg_coercion) ->
         let param' = Ident.rename param in
         let arg = apply_coercion loc Alias arg_coercion (Lvar param') in
-        let params = param' :: params in
+        let params = (param', Pgenval) :: params in
         let body = Llet (Alias, Pgenval, param, arg, body) in
         params, body)
       ([], transl_module res_coercion body_path body)
@@ -452,6 +457,7 @@ let rec compile_functor mexp coercion root_path loc =
   Lfunction {
     kind = Curried;
     params;
+    return = Pgenval;
     attr = {
       inline = inline_attribute;
       specialise = Default_specialise;

bytecomp/translprim.ml

@@ -725,15 +725,18 @@ let transl_primitive loc p env ty path =
     | Some prim -> prim
   in
   let rec make_params n =
-    if n <= 0 then [] else Ident.create_local "prim" :: make_params (n-1)
+    if n <= 0 then []
+    else (Ident.create_local "prim", Pgenval) :: make_params (n-1)
   in
   let params = make_params p.prim_arity in
-  let args = List.map (fun id -> Lvar id) params in
+  let args = List.map (fun (id, _) -> Lvar id) params in
   let body = lambda_of_prim p.prim_name prim loc args None in
   match params with
   | [] -> body
   | _ ->
-      Lfunction{ kind = Curried; params;
+      Lfunction{ kind = Curried;
+                 params;
+                 return = Pgenval;
                  attr = default_stub_attribute;
                  loc = loc;
                  body = body; }

middle_end/closure_conversion.ml

@@ -43,7 +43,7 @@ let add_default_argument_wrappers lam =
         Lfunction {kind; params; body = fbody; attr; loc}, body) ->
       begin match
         Simplif.split_default_wrapper ~id ~kind ~params
-          ~body:fbody ~attr ~loc
+          ~body:fbody ~return:Pgenval ~attr ~loc
       with
       | [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body)
       | [fun_id, def; inner_fun_id, def_inner] ->
@@ -59,7 +59,7 @@ let add_default_argument_wrappers lam =
                (function
                  | (id, Lambda.Lfunction {kind; params; body; attr; loc}) ->
                    Simplif.split_default_wrapper ~id ~kind ~params ~body
-                     ~attr ~loc
+                     ~return:Pgenval ~attr ~loc
                  | _ -> assert false)
                defs)
         in
@@ -205,7 +205,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
     let set_of_closures =
       let decl =
         Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind
-          ~params ~body ~attr ~loc
+          ~params:(List.map fst params) ~body ~attr ~loc
       in
       close_functions t env (Function_decls.create [decl])
     in
@@ -250,7 +250,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
             in
             let function_declaration =
               Function_decl.create ~let_rec_ident:(Some let_rec_ident)
-                ~closure_bound_var ~kind ~params ~body
+                ~closure_bound_var ~kind ~params:(List.map fst params) ~body
                 ~attr ~loc
             in
             Some function_declaration
@@ -482,7 +482,8 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
   | Lstaticcatch (body, (i, ids), handler) ->
     let st_exn = Static_exception.create () in
     let env = Env.add_static_exception env i st_exn in
-    let vars = List.map (Variable.create_with_same_name_as_ident) ids in
+    let ids = List.map fst ids in
+    let vars = List.map Variable.create_with_same_name_as_ident ids in
     Static_catch (st_exn, vars, close t env body,
       close t (Env.add_vars env ids vars) handler)
   | Ltrywith (body, id, handler) ->
@@ -622,8 +623,8 @@ and close_let_bound_expression t ?let_rec_ident let_bound_var env
        names. *)
     let closure_bound_var = Variable.rename let_bound_var in
     let decl =
-      Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~params
+      Function_decl.create ~let_rec_ident ~closure_bound_var ~kind
-        ~body ~attr ~loc
+        ~params:(List.map fst params) ~body ~attr ~loc
     in
     let set_of_closures_var = Variable.rename let_bound_var in
     let set_of_closures =

middle_end/flambda.ml

@@ -243,7 +243,7 @@ let rec lam ppf (flam : t) =
     let print_kind ppf (kind : Lambda.value_kind) =
       match kind with
       | Pgenval -> ()
-      | _ -> Format.fprintf ppf " %s" (Printlambda.value_kind kind)
+      | _ -> Format.fprintf ppf " %a" Printlambda.value_kind kind
     in
     fprintf ppf "@[<2>(let_mutable%a@ @[<2>%a@ %a@]@ %a)@]"
       print_kind contents_kind

testsuite/tests/functors/functors.compilers.reference

@@ -4,22 +4,26 @@
        (module-defn(O) functors.ml(12):184-279
          (function X is_a_functor always_inline
            (let
-             (cow = (function x (apply (field 0 X) x))
+             (cow = (function x[int] : int (apply (field 0 X) x))
-              sheep = (function x (+ 1 (apply cow x))))
+              sheep = (function x[int] : int (+ 1 (apply cow x))))
              (makeblock 0 cow sheep))))
      F =
        (module-defn(F) functors.ml(17):281-392
          (function X Y is_a_functor always_inline
            (let
-             (cow = (function x (apply (field 0 Y) (apply (field 0 X) x)))
+             (cow =
-              sheep = (function x (+ 1 (apply cow x))))
+                (function x[int] : int
+                  (apply (field 0 Y) (apply (field 0 X) x)))
+              sheep = (function x[int] : int (+ 1 (apply cow x))))
              (makeblock 0 cow sheep))))
      F1 =
        (module-defn(F1) functors.ml(31):516-632
          (function X Y is_a_functor always_inline
            (let
-             (cow = (function x (apply (field 0 Y) (apply (field 0 X) x)))
+             (cow =
-              sheep = (function x (+ 1 (apply cow x))))
+                (function x[int] : int
+                  (apply (field 0 Y) (apply (field 0 X) x)))
+              sheep = (function x[int] : int (+ 1 (apply cow x))))
              (makeblock 0 sheep))))
      F2 =
        (module-defn(F2) functors.ml(36):634-784
@@ -27,8 +31,10 @@
            (let
              (X =a (makeblock 0 (field 1 X))
               Y =a (makeblock 0 (field 1 Y))
-              cow = (function x (apply (field 0 Y) (apply (field 0 X) x)))
+              cow =
-              sheep = (function x (+ 1 (apply cow x))))
+                (function x[int] : int
+                  (apply (field 0 Y) (apply (field 0 X) x)))
+              sheep = (function x[int] : int (+ 1 (apply cow x))))
              (makeblock 0 sheep))))
      M =
        (module-defn(M) functors.ml(41):786-970
@@ -38,8 +44,9 @@
                 (function X Y is_a_functor always_inline
                   (let
                     (cow =
-                       (function x (apply (field 0 Y) (apply (field 0 X) x)))
+                       (function x[int] : int
-                     sheep = (function x (+ 1 (apply cow x))))
+                         (apply (field 0 Y) (apply (field 0 X) x)))
+                     sheep = (function x[int] : int (+ 1 (apply cow x))))
                     (makeblock 0 cow sheep)))))
            (makeblock 0
              (function funarg funarg is_a_functor stub

testsuite/tests/translprim/array_spec.compilers.flat.reference

@@ -4,7 +4,7 @@
      float_a = (makearray[float] 1. 2. 3.)
      addr_a = (makearray[addr] "a" "b" "c"))
     (seq (array.length[int] int_a) (array.length[float] float_a)
-      (array.length[addr] addr_a) (function a (array.length[gen] a))
+      (array.length[addr] addr_a) (function a : int (array.length[gen] a))
       (array.get[int] int_a 0) (array.get[float] float_a 0)
       (array.get[addr] addr_a 0) (function a (array.get[gen] a 0))
       (array.unsafe_get[int] int_a 0) (array.unsafe_get[float] float_a 0)

testsuite/tests/translprim/comparison_table.compilers.reference

@@ -1,68 +1,70 @@
 (setglobal Comparison_table!
   (let
-    (gen_cmp = (function x y (caml_compare x y))
+    (gen_cmp = (function x y : int (caml_compare x y))
-     int_cmp = (function x y (caml_int_compare x y))
+     int_cmp = (function x[int] y[int] : int (caml_int_compare x y))
-     bool_cmp = (function x y (caml_int_compare x y))
+     bool_cmp = (function x y : int (caml_int_compare x y))
-     intlike_cmp = (function x y (caml_int_compare x y))
+     intlike_cmp = (function x y : int (caml_int_compare x y))
-     float_cmp = (function x y (caml_float_compare x y))
+     float_cmp = (function x[float] y[float] : int (caml_float_compare x y))
-     string_cmp = (function x y (caml_string_compare x y))
+     string_cmp = (function x y : int (caml_string_compare x y))
-     int32_cmp = (function x y (caml_int32_compare x y))
+     int32_cmp = (function x[int32] y[int32] : int (caml_int32_compare x y))
-     int64_cmp = (function x y (caml_int64_compare x y))
+     int64_cmp = (function x[int64] y[int64] : int (caml_int64_compare x y))
-     nativeint_cmp = (function x y (caml_nativeint_compare x y))
+     nativeint_cmp =
+       (function x[nativeint] y[nativeint] : int
+         (caml_nativeint_compare x y))
      gen_eq = (function x y (caml_equal x y))
-     int_eq = (function x y (== x y))
+     int_eq = (function x[int] y[int] (== x y))
      bool_eq = (function x y (== x y))
      intlike_eq = (function x y (== x y))
-     float_eq = (function x y (==. x y))
+     float_eq = (function x[float] y[float] (==. x y))
      string_eq = (function x y (caml_string_equal x y))
-     int32_eq = (function x y (Int32.== x y))
+     int32_eq = (function x[int32] y[int32] (Int32.== x y))
-     int64_eq = (function x y (Int64.== x y))
+     int64_eq = (function x[int64] y[int64] (Int64.== x y))
-     nativeint_eq = (function x y (Nativeint.== x y))
+     nativeint_eq = (function x[nativeint] y[nativeint] (Nativeint.== x y))
      gen_ne = (function x y (caml_notequal x y))
-     int_ne = (function x y (!= x y))
+     int_ne = (function x[int] y[int] (!= x y))
      bool_ne = (function x y (!= x y))
      intlike_ne = (function x y (!= x y))
-     float_ne = (function x y (!=. x y))
+     float_ne = (function x[float] y[float] (!=. x y))
      string_ne = (function x y (caml_string_notequal x y))
-     int32_ne = (function x y (Int32.!= x y))
+     int32_ne = (function x[int32] y[int32] (Int32.!= x y))
-     int64_ne = (function x y (Int64.!= x y))
+     int64_ne = (function x[int64] y[int64] (Int64.!= x y))
-     nativeint_ne = (function x y (Nativeint.!= x y))
+     nativeint_ne = (function x[nativeint] y[nativeint] (Nativeint.!= x y))
      gen_lt = (function x y (caml_lessthan x y))
-     int_lt = (function x y (< x y))
+     int_lt = (function x[int] y[int] (< x y))
      bool_lt = (function x y (< x y))
      intlike_lt = (function x y (< x y))
-     float_lt = (function x y (<. x y))
+     float_lt = (function x[float] y[float] (<. x y))
      string_lt = (function x y (caml_string_lessthan x y))
-     int32_lt = (function x y (Int32.< x y))
+     int32_lt = (function x[int32] y[int32] (Int32.< x y))
-     int64_lt = (function x y (Int64.< x y))
+     int64_lt = (function x[int64] y[int64] (Int64.< x y))
-     nativeint_lt = (function x y (Nativeint.< x y))
+     nativeint_lt = (function x[nativeint] y[nativeint] (Nativeint.< x y))
      gen_gt = (function x y (caml_greaterthan x y))
-     int_gt = (function x y (> x y))
+     int_gt = (function x[int] y[int] (> x y))
      bool_gt = (function x y (> x y))
      intlike_gt = (function x y (> x y))
-     float_gt = (function x y (>. x y))
+     float_gt = (function x[float] y[float] (>. x y))
      string_gt = (function x y (caml_string_greaterthan x y))
-     int32_gt = (function x y (Int32.> x y))
+     int32_gt = (function x[int32] y[int32] (Int32.> x y))
-     int64_gt = (function x y (Int64.> x y))
+     int64_gt = (function x[int64] y[int64] (Int64.> x y))
-     nativeint_gt = (function x y (Nativeint.> x y))
+     nativeint_gt = (function x[nativeint] y[nativeint] (Nativeint.> x y))
      gen_le = (function x y (caml_lessequal x y))
-     int_le = (function x y (<= x y))
+     int_le = (function x[int] y[int] (<= x y))
      bool_le = (function x y (<= x y))
      intlike_le = (function x y (<= x y))
-     float_le = (function x y (<=. x y))
+     float_le = (function x[float] y[float] (<=. x y))
      string_le = (function x y (caml_string_lessequal x y))
-     int32_le = (function x y (Int32.<= x y))
+     int32_le = (function x[int32] y[int32] (Int32.<= x y))
-     int64_le = (function x y (Int64.<= x y))
+     int64_le = (function x[int64] y[int64] (Int64.<= x y))
-     nativeint_le = (function x y (Nativeint.<= x y))
+     nativeint_le = (function x[nativeint] y[nativeint] (Nativeint.<= x y))
      gen_ge = (function x y (caml_greaterequal x y))
-     int_ge = (function x y (>= x y))
+     int_ge = (function x[int] y[int] (>= x y))
      bool_ge = (function x y (>= x y))
      intlike_ge = (function x y (>= x y))
-     float_ge = (function x y (>=. x y))
+     float_ge = (function x[float] y[float] (>=. x y))
      string_ge = (function x y (caml_string_greaterequal x y))
-     int32_ge = (function x y (Int32.>= x y))
+     int32_ge = (function x[int32] y[int32] (Int32.>= x y))
-     int64_ge = (function x y (Int64.>= x y))
+     int64_ge = (function x[int64] y[int64] (Int64.>= x y))
-     nativeint_ge = (function x y (Nativeint.>= x y))
+     nativeint_ge = (function x[nativeint] y[nativeint] (Nativeint.>= x y))
      eta_gen_cmp = (function prim prim stub (caml_compare prim prim))
      eta_int_cmp = (function prim prim stub (caml_int_compare prim prim))
      eta_bool_cmp = (function prim prim stub (caml_int_compare prim prim))

typing/typeclass.ml

@@ -1158,7 +1158,7 @@ and class_expr_aux cl_num val_env met_env scl =
         Typecore.type_let In_class_def val_env rec_flag sdefs None in
       let (vals, met_env) =
         List.fold_right
-          (fun (id, _id_loc) (vals, met_env) ->
+          (fun (id, _id_loc, _typ) (vals, met_env) ->
              let path = Pident id in
              (* do not mark the value as used *)
              let vd = Env.find_value path val_env in

typing/typedtree.ml

@@ -606,19 +606,19 @@ let map_pattern_desc f d =
 
 (* List the identifiers bound by a pattern or a let *)
 
-let idents = ref([]: (Ident.t * string loc) list)
+let idents = ref([]: (Ident.t * string loc * Types.type_expr) list)
 
 let rec bound_idents pat =
   match pat.pat_desc with
-  | Tpat_var (id,s) -> idents := (id,s) :: !idents
+  | Tpat_var (id,s) -> idents := (id,s,pat.pat_type) :: !idents
-  | Tpat_alias(p, id, s ) ->
+  | Tpat_alias(p, id, s) ->
-      bound_idents p; idents := (id,s) :: !idents
+      bound_idents p; idents := (id,s,pat.pat_type) :: !idents
   | Tpat_or(p1, _, _) ->
       (* Invariant : both arguments binds the same variables *)
       bound_idents p1
   | d -> iter_pattern_desc bound_idents d
 
-let pat_bound_idents_with_loc pat =
+let pat_bound_idents_full pat =
   idents := [];
   bound_idents pat;
   let res = !idents in
@@ -626,7 +626,7 @@ let pat_bound_idents_with_loc pat =
   res
 
 let pat_bound_idents pat =
-  List.map fst (pat_bound_idents_with_loc pat)
+  List.map (fun (id,_,_) -> id) (pat_bound_idents_full pat)
 
 let rev_let_bound_idents_with_loc bindings =
   idents := [];
@@ -636,8 +636,11 @@ let rev_let_bound_idents_with_loc bindings =
 let let_bound_idents_with_loc pat_expr_list =
   List.rev(rev_let_bound_idents_with_loc pat_expr_list)
 
-let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat)
+let rev_let_bound_idents pat =
-let let_bound_idents pat = List.map  fst (let_bound_idents_with_loc pat)
+  List.map (fun (id,_,_) -> id) (rev_let_bound_idents_with_loc pat)
+
+let let_bound_idents pat =
+  List.map (fun (id,_,_) -> id) (let_bound_idents_with_loc pat)
 
 let alpha_var env id = List.assoc id env
 

typing/typedtree.mli

@@ -697,7 +697,7 @@ val let_bound_idents: value_binding list -> Ident.t list
 val rev_let_bound_idents: value_binding list -> Ident.t list
 
 val let_bound_idents_with_loc:
-    value_binding list -> (Ident.t * string loc) list
+    value_binding list -> (Ident.t * string loc * type_expr) list
 
 (** Alpha conversion of patterns *)
 val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern
@@ -706,7 +706,8 @@ val mknoloc: 'a -> 'a Asttypes.loc
 val mkloc: 'a -> Location.t -> 'a Asttypes.loc
 
 val pat_bound_idents: pattern -> Ident.t list
-val pat_bound_idents_with_loc: pattern -> (Ident.t * string loc) list
+val pat_bound_idents_full:
+  pattern -> (Ident.t * string loc * type_expr) list
 
 (** Splits an or pattern into its value (left) and exception (right) parts. *)
 val split_pattern : pattern -> pattern option * pattern option

typing/typemod.ml

@@ -1913,7 +1913,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         (* Note: Env.find_value does not trigger the value_used event. Values
            will be marked as being used during the signature inclusion test. *)
         Tstr_value(rec_flag, defs),
-        List.map (fun (id, { Asttypes.loc; _ })->
+        List.map (fun (id, { Asttypes.loc; _ }, _typ)->
           Signature_names.check_value names loc id;
           Sig_value(id, Env.find_value (Pident id) newenv)
         ) (let_bound_idents_with_loc defs),

typing/typeopt.ml

@@ -171,6 +171,10 @@ let value_kind env ty =
   | _ ->
       Pgenval
 
+let function_return_value_kind env ty =
+  match is_function_type env ty with
+  | Some (_lhs, rhs) -> value_kind env rhs
+  | None -> Pgenval
 
 (** Whether a forward block is needed for a lazy thunk on a value, i.e.
     if the value can be represented as a float/forward/lazy *)
@@ -205,3 +209,7 @@ let classify_lazy_argument : Typedtree.expression ->
        `Identifier `Other
     | _ ->
        `Other
+
+let value_kind_union k1 k2 =
+  if k1 = k2 then k1
+  else Pgenval

typing/typeopt.mli

@@ -29,9 +29,15 @@ 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
 val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+val function_return_value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
 
 val classify_lazy_argument : Typedtree.expression ->
                              [ `Constant_or_function
                              | `Float_that_cannot_be_shortcut
                              | `Identifier of [`Forward_value | `Other]
                              | `Other]
+
+val value_kind_union :
+      Lambda.value_kind -> Lambda.value_kind -> Lambda.value_kind
+  (** [value_kind_union k1 k2] is a value_kind at least as general as
+      [k1] and [k2] *)