Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Keep more type information in Lambda (#2156) 

* Propagate type information about function parameters and return

* Keep value kind on staticcatch parameters
master
Alain Frisch 2018-11-23 15:34:05 +01:00 committed by GitHub
parent 4c130cae87
commit 7a746deed1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
31 changed files with 455 additions and 284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Changes
View File

@ -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

9
asmcomp/clambda.ml
View File

@ -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;

9
asmcomp/clambda.mli
View File

@ -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;

42
asmcomp/closure.ml
View File

@ -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;
)

4
asmcomp/cmmgen.ml
View File

@ -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}

11
asmcomp/flambda_to_clambda.ml
View File

@ -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;

39
asmcomp/printclambda.ml
View File

@ -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
| [] -> ()
| _ ->
List.iter
(fun x -> fprintf ppf " %a" VP.print x)
vars)
(fun ppf vars ->
List.iter
(fun (x, k) ->
fprintf ppf " %a%a"
VP.print x
Printlambda.value_kind k
)
vars
)
vars
lam lhandler
| Utrywith(lbody, param, lhandler) ->

19
asmcomp/un_anf.ml
View File

@ -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 := [];

8
bytecomp/bytegen.ml
View File

@ -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;
num_defs = ndecl; rec_vars = rec_idents; rec_pos = pos} in
{ params = List.map fst params; body = body; label = lbl;
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 =

32
bytecomp/lambda.ml
View File

@ -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} ->
let s = List.fold_right Ident.Map.remove params s in
Lfunction{kind; params; body = subst s body; attr; loc}
| Lfunction lf ->
let s =
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; body = map f body; attr; loc; }
| Lfunction { kind; params; return; 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

7
bytecomp/lambda.mli
View File

@ -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

61
bytecomp/matching.ml
View File

@ -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) &&
Ident.Set.is_empty (extract_vars Ident.Set.empty q) &&
Typedtree.pat_bound_idents p = [] &&
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
(Ident.Set.inter
(extract_vars Ident.Set.empty orp)
(pm_free_variables orpm)) in
Typedtree.pat_bound_idents_full orp
|> List.filter (fun (id, _, _) -> Ident.Set.mem id pm_fv)
|> List.map (fun (id,_,ty) -> id,Typeopt.value_kind orp.pat_env ty)
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 bind = map_return (assign_pat opt nraise catch_ids loc pat) param in
if !opt then Lstaticcatch(bind, (nraise, catch_ids), body)
let catch_ids = pat_bound_idents_full pat in
let ids_with_kinds =
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 *)

49
bytecomp/printlambda.ml
View File

@ -54,11 +54,17 @@ let boxed_integer_name = function
| Pint32 -> "int32"
| Pint64 -> "int64"
let value_kind = function
| Pgenval -> ""
| Pintval -> "[int]"
| Pfloatval -> "[float]"
| Pboxedintval bi -> Printf.sprintf "[%s]" (boxed_integer_name bi)
let value_kind ppf = function
| Pgenval -> ()
| Pintval -> fprintf ppf "[int]"
| Pfloatval -> fprintf ppf "[float]"
| 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
function_attribute attr lam body
fprintf ppf "@[<2>(function%a@ %a%a%a)@]" pr_params params
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@]"
Ident.print id (kind str) (value_kind k) lam arg;
fprintf ppf "@ @[<2>%a =%s%a@ %a@]"
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@]"
Ident.print id (kind str) (value_kind k) lam arg;
fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s%a@ %a@]"
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
| [] -> ()
| _ ->
List.iter
(fun x -> fprintf ppf " %a" Ident.print x)
vars)
(fun ppf vars ->
List.iter
(fun (x, k) -> fprintf ppf " %a%a" Ident.print x value_kind k)
vars
)
vars
lam lhandler
| Ltrywith(lbody, param, lhandler) ->

3
bytecomp/printlambda.mli
View File

@ -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

45
bytecomp/simplif.ml
View File

@ -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; body = simplif l; attr; loc}
| Lfunction{kind; params; return; body = 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 env = List.fold_right2 Ident.Map.add xs ys Ident.Map.empty in
let ys = List.map (fun (x, k) -> Ident.rename x, k) xs 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

3
bytecomp/simplif.mli
View File

@ -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

61
bytecomp/translclass.ml
View File

@ -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
(inh_init, lfunction [env] (subst_env env inh_init obj_init))
if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in
(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;
loc = Location.none;
params = [cla]; body = def_ids cla cl_init})
lset cached 0
(Lfunction
{
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

116
bytecomp/translcore.ml
View File

@ -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
param pl)
let return_kind = function_return_value_kind e.exp_env e.exp_type in
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 = id_arg::ids; body = lam; attr;
Lfunction{kind = Curried; params = ids; return;
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) =
transl_function exp.exp_loc false repr partial' param' cases in
((Curried, param :: params),
let kind = value_kind pat.pat_env pat.pat_type in
let return_kind = function_return_value_kind exp_env exp_type in
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
((Tupled, params),
let kinds =
(* 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
| _ ->
((Curried, [param]),
| {c_lhs=pat} :: other_cases ->
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 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)
let val_ids =
List.map
(fun arg ->
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
static_catch [transl_exp arg] [val_id]
(Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial)
let val_id = Typecore.name_cases "val" pat_expr_list in
let k = Typeopt.value_kind arg.exp_env arg.exp_type in
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)

40
bytecomp/translmod.ml
View File

@ -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 ->
Lfunction{kind = Curried; params = List.rev params;
attr = { default_function_attribute with
is_a_functor = true;
stub = true; };
loc = loc;
body = apply_coercion
loc Strict cc_res
(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})})
name_lambda strict funct
(fun id ->
Lfunction
{
kind = Curried;
params = List.rev params;
return = Pgenval;
attr = { default_function_attribute with
is_a_functor = true;
stub = true; };
loc = loc;
body = apply_coercion
loc Strict cc_res
(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;

9
bytecomp/translprim.ml
View File

@ -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; }

15
middle_end/closure_conversion.ml
View File

@ -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
~body ~attr ~loc
Function_decl.create ~let_rec_ident ~closure_bound_var ~kind
~params:(List.map fst params) ~body ~attr ~loc
in
let set_of_closures_var = Variable.rename let_bound_var in
let set_of_closures =

2
middle_end/flambda.ml
View File

@ -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

27
testsuite/tests/functors/functors.compilers.reference
View File

@ -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))
sheep = (function x (+ 1 (apply cow x))))
(cow = (function x[int] : int (apply (field 0 X) 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)))
sheep = (function x (+ 1 (apply cow x))))
(cow =
(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)))
sheep = (function x (+ 1 (apply cow x))))
(cow =
(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)))
sheep = (function x (+ 1 (apply cow x))))
cow =
(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)))
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)))))
(makeblock 0
(function funarg funarg is_a_functor stub

2
testsuite/tests/translprim/array_spec.compilers.flat.reference
View File

@ -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)

80
testsuite/tests/translprim/comparison_table.compilers.reference
View File

@ -1,68 +1,70 @@
(setglobal Comparison_table!
(let
(gen_cmp = (function x y (caml_compare x y))
int_cmp = (function x y (caml_int_compare x y))
bool_cmp = (function x y (caml_int_compare x y))
intlike_cmp = (function x y (caml_int_compare x y))
float_cmp = (function x y (caml_float_compare x y))
string_cmp = (function x y (caml_string_compare x y))
int32_cmp = (function x y (caml_int32_compare x y))
int64_cmp = (function x y (caml_int64_compare x y))
nativeint_cmp = (function x y (caml_nativeint_compare x y))
(gen_cmp = (function x y : int (caml_compare x y))
int_cmp = (function x[int] y[int] : int (caml_int_compare x y))
bool_cmp = (function x y : int (caml_int_compare x y))
intlike_cmp = (function x y : int (caml_int_compare x y))
float_cmp = (function x[float] y[float] : int (caml_float_compare x y))
string_cmp = (function x y : int (caml_string_compare x y))
int32_cmp = (function x[int32] y[int32] : int (caml_int32_compare x y))
int64_cmp = (function x[int64] y[int64] : int (caml_int64_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))
int64_eq = (function x y (Int64.== x y))
nativeint_eq = (function x y (Nativeint.== x y))
int32_eq = (function x[int32] y[int32] (Int32.== x y))
int64_eq = (function x[int64] y[int64] (Int64.== 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))
int64_ne = (function x y (Int64.!= x y))
nativeint_ne = (function x y (Nativeint.!= x y))
int32_ne = (function x[int32] y[int32] (Int32.!= x y))
int64_ne = (function x[int64] y[int64] (Int64.!= 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))
int64_lt = (function x y (Int64.< x y))
nativeint_lt = (function x y (Nativeint.< x y))
int32_lt = (function x[int32] y[int32] (Int32.< x y))
int64_lt = (function x[int64] y[int64] (Int64.< 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))
int64_gt = (function x y (Int64.> x y))
nativeint_gt = (function x y (Nativeint.> x y))
int32_gt = (function x[int32] y[int32] (Int32.> x y))
int64_gt = (function x[int64] y[int64] (Int64.> 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))
int64_le = (function x y (Int64.<= x y))
nativeint_le = (function x y (Nativeint.<= x y))
int32_le = (function x[int32] y[int32] (Int32.<= x y))
int64_le = (function x[int64] y[int64] (Int64.<= 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))
int64_ge = (function x y (Int64.>= x y))
nativeint_ge = (function x y (Nativeint.>= x y))
int32_ge = (function x[int32] y[int32] (Int32.>= x y))
int64_ge = (function x[int64] y[int64] (Int64.>= 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))

2
typing/typeclass.ml
View File

@ -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

19
typing/typedtree.ml
View File

@ -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_alias(p, id, s ) ->
bound_idents p; idents := (id,s) :: !idents
| Tpat_var (id,s) -> idents := (id,s,pat.pat_type) :: !idents
| Tpat_alias(p, id, s) ->
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 let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat)
let rev_let_bound_idents 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

5
typing/typedtree.mli
View File

@ -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

2
typing/typemod.ml
View File

@ -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),

8
typing/typeopt.ml
View File

@ -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

6
typing/typeopt.mli
View File

@ -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] *)