Keep more type information in Lambda (#2156)
* Propagate type information about function parameters and return * Keep value kind on staticcatch parametersmaster
parent
4c130cae87
commit
7a746deed1
4
Changes
4
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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
)
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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 -> fprintf ppf " %a" VP.print x)
|
||||
vars)
|
||||
(fun (x, k) ->
|
||||
fprintf ppf " %a%a"
|
||||
VP.print x
|
||||
Printlambda.value_kind k
|
||||
)
|
||||
vars
|
||||
)
|
||||
vars
|
||||
lam lhandler
|
||||
| Utrywith(lbody, param, lhandler) ->
|
||||
|
|
|
@ -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 := [];
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
@ -1130,11 +1116,12 @@ and precompile_or argo cls ors args def k = match ors with
|
|||
others ;
|
||||
args = (match args with _::r -> r | _ -> assert false) ;
|
||||
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 *)
|
||||
|
|
|
@ -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
|
||||
| [] -> ()
|
||||
| _ ->
|
||||
(fun ppf vars ->
|
||||
List.iter
|
||||
(fun x -> fprintf ppf " %a" Ident.print x)
|
||||
vars)
|
||||
(fun (x, k) -> fprintf ppf " %a%a" Ident.print x value_kind k)
|
||||
vars
|
||||
)
|
||||
vars
|
||||
lam lhandler
|
||||
| Ltrywith(lbody, param, lhandler) ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 y l r -> Llet (Alias, Pgenval, y, l, r))
|
||||
(fun (x, _) (y, _) env -> Ident.Map.add x y env)
|
||||
xs ys Ident.Map.empty
|
||||
in
|
||||
List.fold_right2
|
||||
(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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
lset cached 0
|
||||
(Lfunction
|
||||
{
|
||||
kind = Curried;
|
||||
attr = default_function_attribute;
|
||||
loc = Location.none;
|
||||
params = [cla]; body = def_ids cla cl_init})
|
||||
return = Pgenval;
|
||||
params = [cla, Pgenval];
|
||||
body = def_ids cla cl_init;
|
||||
}
|
||||
)
|
||||
in
|
||||
let lupdate_cache =
|
||||
if ids = [] then ldirect () else
|
||||
|
|
|
@ -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,8 +924,15 @@ 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
|
||||
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, [] ->
|
||||
|
@ -883,7 +940,8 @@ and transl_match e arg pat_expr_list partial =
|
|||
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]
|
||||
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) ->
|
||||
|
|
|
@ -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,10 +100,15 @@ 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;
|
||||
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; };
|
||||
|
@ -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;
|
||||
|
|
|
@ -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; }
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) ->
|
||||
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 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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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),
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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] *)
|
||||
|
|
Loading…
Reference in New Issue