let path =

Printtyp.wrap_printing_env env ~error:true (fun () ->

Option.map (Out_type.rewrite_double_underscore_paths env) path)

in

let name =

match path, !Clflags.for_package with

None, _ -> Ident.name ext.ext_id

| Some p, None -> Path.name p

| Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)

in

let loc = of_location ~scopes ext.ext_loc in

match ext.ext_kind with

Text_decl _ ->

Lprim (Pmakeblock (Obj.object_tag, Immutable, None),

[Lconst (Const_immstring name);

Lprim (prim_fresh_oo_id, [Lconst (const_int 0)], loc)],

loc)

| Text_rebind(path, _lid) ->

if !Clflags.debug && not !Clflags.native_code then

let repr = Some (ref 0) in

let (info, body) = lam repr in

(info,

Levent(body, {lev_loc = of_location ~scopes exp.exp_loc;

lev_kind = Lev_function;

lev_repr = repr;

lev_env = exp.exp_env}))

else

let slot =

transl_extension_path Loc_unknown

Env.initial Predef.path_assert_failure

in

let (fname, line, char) =

Location.get_pos_info loc.Location.loc_start

in

let loc = of_location ~scopes exp.exp_loc in

Lprim(Praise Raise_regular, [event_after ~scopes exp

(Lprim(Pmakeblock(0, Immutable, None),

[slot;

Lconst(Const_block(0,

[Const_immstring fname;

Const_int line;

match parent_body with

| Tfunction_body

{ exp_desc = Texp_function (method_params, method_body);

exp_extra;

}

when

List.exists

(function (Texp_poly _, _, _) -> true | _ -> false)

exp_extra

-> parent_params @ method_params, method_body

match pat.pat_desc with

| Tpat_var (id, _, _) -> f id

| Tpat_alias (p, id, _, _, _) ->

f id;

iter_exn_names f p

match desc.val_kind with

| Val_prim p ->

Translprim.transl_primitive loc p env ty (Some path)

| Val_anc _ ->

raise(Error(to_location loc, Free_super_var))

| Val_reg | Val_self _ ->

transl_value_path loc env path

let eval_once =

(* Whether classes for immediate objects must be cached *)

match e.exp_desc with

Texp_function _ | Texp_for _ | Texp_while _ -> false

| _ -> true

in

if eval_once then transl_exp0 ~scopes ~in_new_scope e else

match e.exp_desc with

| Texp_ident(path, _, desc) ->

transl_ident (of_location ~scopes e.exp_loc)

e.exp_env e.exp_type path desc

| Texp_constant cst ->

Lambda.lambda_of_const cst

| Texp_let(rec_flag, pat_expr_list, body) ->

transl_let ~scopes rec_flag pat_expr_list

(event_before ~scopes body (transl_exp ~scopes body))

| Texp_function (params, body) ->

let scopes =

if in_new_scope then scopes

else enter_anonymous_function ~scopes

in

transl_function ~scopes e params body

| 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

&& List.for_all (fun (_, arg) -> not (is_omitted arg)) oargs ->

let argl, extra_args = cut p.prim_arity oargs in

let arg_exps =

List.map (function _, Arg x -> x | _, Omitted () -> assert false) argl

in

let args = transl_list ~scopes arg_exps in

let prim_exp = if extra_args = [] then Some e else None in

let lam =

Translprim.transl_primitive_application

(of_location ~scopes e.exp_loc) p e.exp_env prim_type path

prim_exp args arg_exps

in

if extra_args = [] then lam

else begin

let tailcall = Translattribute.get_tailcall_attribute funct in

let inlined = Translattribute.get_inlined_attribute funct in

let specialised = Translattribute.get_specialised_attribute funct in

let e = { e with exp_desc = Texp_apply(funct, oargs) } in

event_after ~scopes e

(transl_apply ~scopes ~tailcall ~inlined ~specialised

lam extra_args (of_location ~scopes e.exp_loc))

end

| Texp_apply(funct, oargs) ->

let tailcall = Translattribute.get_tailcall_attribute funct in

let inlined = Translattribute.get_inlined_attribute funct in

let specialised = Translattribute.get_specialised_attribute funct in

let e = { e with exp_desc = Texp_apply(funct, oargs) } in

event_after ~scopes e

(transl_apply ~scopes ~tailcall ~inlined ~specialised

(transl_exp ~scopes funct) oargs (of_location ~scopes e.exp_loc))

| Texp_match(arg, pat_expr_list, [], partial) ->

transl_match ~scopes e arg pat_expr_list partial

| Texp_match(arg, pat_expr_list, eff_pat_expr_list, partial) ->

(* need to separate the values from exceptions for transl_handler *)

let split_case (val_cases, exn_cases as acc)

({ c_lhs; c_rhs } as case) =

if c_rhs.exp_desc = Texp_unreachable then acc else

let val_pat, exn_pat = split_pattern c_lhs in

match val_pat, exn_pat with

| None, None -> assert false

| Some pv, None ->

{ case with c_lhs = pv } :: val_cases, exn_cases

| None, Some pe ->

val_cases, { case with c_lhs = pe } :: exn_cases

| Some pv, Some pe ->

{ case with c_lhs = pv } :: val_cases,

{ case with c_lhs = pe } :: exn_cases

in

let pat_expr_list, exn_pat_expr_list =

let x, y = List.fold_left split_case ([], []) pat_expr_list in

List.rev x, List.rev y

in

transl_handler ~scopes e arg (Some (pat_expr_list, partial))

exn_pat_expr_list eff_pat_expr_list

| Texp_try(body, pat_expr_list, []) ->

let id = Typecore.name_cases "exn" pat_expr_list in

Ltrywith(transl_exp ~scopes body, id,

Matching.for_trywith ~scopes e.exp_loc (Lvar id)

(transl_cases_try ~scopes pat_expr_list))

| Texp_try(body, exn_pat_expr_list, eff_pat_expr_list) ->

transl_handler ~scopes e body None exn_pat_expr_list eff_pat_expr_list

| Texp_tuple el ->

let ll, shape = transl_list_with_shape ~scopes (List.map snd el) in

begin try

Lconst(Const_block(0, List.map extract_constant ll))

with Not_constant ->

Lprim(Pmakeblock(0, Immutable, Some shape), ll,

(of_location ~scopes e.exp_loc))

end

| Texp_construct(_, cstr, args) ->

let ll, shape = transl_list_with_shape ~scopes args in

if cstr.cstr_inlined <> None then begin match ll with

| [x] -> x

| _ -> assert false

end else begin match cstr.cstr_tag with

Cstr_constant n ->

Lconst(const_int n)

| Cstr_unboxed ->

(match ll with [v] -> v | _ -> assert false)

| Cstr_block n ->

begin try

Lconst(Const_block(n, List.map extract_constant ll))

with Not_constant ->

Lprim(Pmakeblock(n, Immutable, Some shape), ll,

of_location ~scopes e.exp_loc)

end

| Cstr_extension(path, is_const) ->

let lam = transl_extension_path

(of_location ~scopes e.exp_loc) e.exp_env path in

if is_const then lam

else

Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),

lam :: ll, of_location ~scopes e.exp_loc)

end

| Texp_extension_constructor (_, path) ->

transl_extension_path (of_location ~scopes e.exp_loc) e.exp_env path

| Texp_variant(l, arg) ->

let tag = Btype.hash_variant l in

begin match arg with

None -> Lconst(const_int tag)

| Some arg ->

let lam = transl_exp ~scopes arg in

try

Lconst(Const_block(0, [const_int tag;

extract_constant lam]))

with Not_constant ->

Lprim(Pmakeblock(0, Immutable, None),

[Lconst(const_int tag); lam],

of_location ~scopes e.exp_loc)

end

| Texp_record {fields; representation; extended_expression} ->

transl_record ~scopes e.exp_loc e.exp_env

fields representation extended_expression

| Texp_atomic_loc (arg, _, lbl) ->

let shape = Some [Typeopt.value_kind arg.exp_env arg.exp_type; Pintval] in

let (arg, lbl) = transl_atomic_loc ~scopes arg lbl in

let loc = of_location ~scopes e.exp_loc in

Lprim (Pmakeblock (0, Immutable, shape), [arg; lbl], loc)

| Texp_field (arg, _, ({ lbl_atomic = Atomic; _ } as lbl)) ->

let arg, lbl = transl_atomic_loc ~scopes arg lbl in

let loc = of_location ~scopes e.exp_loc in

Lprim (Patomic_load, [arg; lbl], loc)

| Texp_field (arg, _, lbl) ->

let targ = transl_exp ~scopes arg in

begin match lbl.lbl_repres with

Record_regular | Record_inlined _ ->

Lprim (Pfield (lbl.lbl_pos, maybe_pointer e, lbl.lbl_mut), [targ],

of_location ~scopes e.exp_loc)

| Record_unboxed _ -> targ

| Record_float ->

Lprim (Pfloatfield lbl.lbl_pos, [targ],

of_location ~scopes e.exp_loc)

| Record_extension _ ->

Lprim (Pfield (lbl.lbl_pos + 1, maybe_pointer e, lbl.lbl_mut), [targ],

of_location ~scopes e.exp_loc)

end

| Texp_setfield (arg, _, ({ lbl_atomic = Atomic; _ } as lbl), newval) ->

let prim =

Primitive.simple

~name:"caml_atomic_exchange_field" ~arity:3 ~alloc:false

in

let arg, lbl = transl_atomic_loc ~scopes arg lbl in

let newval = transl_exp ~scopes newval in

let loc = of_location ~scopes e.exp_loc in

Lprim (

Pignore,

[Lprim (Pccall prim, [arg; lbl; newval], loc)],

loc

)

| Texp_setfield(arg, _, lbl, newval) ->

let access =

match lbl.lbl_repres with

Record_regular

| Record_inlined _ ->

Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)

| Record_unboxed _ -> assert false

| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)

| Record_extension _ ->

Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)

in

Lprim(access, [transl_exp ~scopes arg; transl_exp ~scopes newval],

of_location ~scopes e.exp_loc)

| Texp_array (amut, expr_list) ->

let kind = array_kind e in

let ll = transl_list ~scopes expr_list in

let loc = of_location ~scopes e.exp_loc in

let makearray mutability =

Lprim (Pmakearray (kind, mutability), ll, loc)

in

let duparray_to_mutable array =

Lprim (Pduparray (kind, Mutable), [array], loc)

in

let imm_array = makearray Immutable in

begin try

(* For native code the decision as to which compilation strategy to

(* Deactivate constant optimization if array is small enough *)

if amut = Asttypes.Mutable &&

List.length ll <= use_dup_for_constant_mutable_arrays_bigger_than

then begin

raise Not_constant

end;

begin match List.map extract_constant ll with

| exception Not_constant

when kind = Pfloatarray && amut = Asttypes.Mutable ->

(* We cannot currently lift mutable [Pintarray] arrays safely in

duparray_to_mutable imm_array

| cl ->

let const =

match kind with

| Paddrarray | Pintarray ->

Lconst(Const_block(0, cl))

| Pfloatarray ->

Lconst(Const_float_array(List.map extract_float cl))

| Pgenarray ->

raise Not_constant (* can this really happen? *)

in

match amut with

| Mutable -> duparray_to_mutable const

| Immutable -> const

end

with Not_constant ->

makearray amut

end

| Texp_ifthenelse(cond, ifso, Some ifnot) ->

Lifthenelse(transl_exp ~scopes cond,

event_before ~scopes ifso (transl_exp ~scopes ifso),

event_before ~scopes ifnot (transl_exp ~scopes ifnot))

| Texp_ifthenelse(cond, ifso, None) ->

Lifthenelse(transl_exp ~scopes cond,

event_before ~scopes ifso (transl_exp ~scopes ifso),

lambda_unit)

| Texp_sequence(expr1, expr2) ->

Lsequence(transl_exp ~scopes expr1,

event_before ~scopes expr2 (transl_exp ~scopes expr2))

| Texp_while(cond, body) ->

Lwhile(transl_exp ~scopes cond,

event_before ~scopes body (transl_exp ~scopes body))

| Texp_for(param, _, low, high, dir, body) ->

Lfor(param, transl_exp ~scopes low, transl_exp ~scopes high, dir,

event_before ~scopes body (transl_exp ~scopes body))

| Texp_send(expr, met) ->

let lam =

let loc = of_location ~scopes e.exp_loc in

match met with

| Tmeth_val id ->

let obj = transl_exp ~scopes expr in

Lsend (Self, Lvar id, obj, [], loc)

| Tmeth_name nm ->

let obj = transl_exp ~scopes expr in

let (tag, cache) = Translobj.meth obj nm in

let kind = if cache = [] then Public else Cached in

Lsend (kind, tag, obj, cache, loc)

| Tmeth_ancestor(meth, path_self) ->

let self = transl_value_path loc e.exp_env path_self in

Lapply {ap_loc = loc;

ap_func = Lvar meth;

ap_args = [self];

ap_tailcall = Default_tailcall;

ap_inlined = Default_inline;

ap_specialised = Default_specialise}

in

event_after ~scopes e lam

| Texp_new (cl, {Location.loc=loc}, _) ->

let loc = of_location ~scopes loc in

Lapply{

ap_loc=loc;

ap_func=

Lprim(Pfield (0, Pointer, Mutable),

[transl_class_path loc e.exp_env cl], loc);

ap_args=[lambda_unit];

ap_tailcall=Default_tailcall;

ap_inlined=Default_inline;

ap_specialised=Default_specialise;

}

| Texp_instvar(path_self, path, _) ->

let loc = of_location ~scopes e.exp_loc in

let self = transl_value_path loc e.exp_env path_self in

let var = transl_value_path loc e.exp_env path in

Lprim(Pfield_computed, [self; var], loc)

| Texp_setinstvar(path_self, path, _, expr) ->

let loc = of_location ~scopes e.exp_loc in

let self = transl_value_path loc e.exp_env path_self in

let var = transl_value_path loc e.exp_env path in

transl_setinstvar ~scopes loc self var expr

| Texp_override(path_self, modifs) ->

let loc = of_location ~scopes e.exp_loc in

let self = transl_value_path loc e.exp_env path_self in

let cpy = Ident.create_local "copy" in

Llet(Strict, Pgenval, cpy,

Lapply{

ap_loc=Loc_unknown;

ap_func=Translobj.oo_prim "copy";

ap_args=[self];

ap_tailcall=Default_tailcall;

ap_inlined=Default_inline;

ap_specialised=Default_specialise;

},

List.fold_right

(fun (id, _, expr) rem ->

Lsequence(transl_setinstvar ~scopes Loc_unknown

(Lvar cpy) (Lvar id) expr, rem))

modifs

(Lvar cpy))

| Texp_pack modl ->

!transl_module ~scopes Tcoerce_none None modl

| Texp_assert ({exp_desc=Texp_construct(_, {cstr_name="false"}, _)}, loc) ->

assert_failed loc ~scopes e

| Texp_assert (cond, loc) ->

if !Clflags.noassert

then lambda_unit

else Lifthenelse (transl_exp ~scopes cond, lambda_unit,

assert_failed loc ~scopes e)

| Texp_lazy e ->

begin match Typeopt.classify_lazy_argument e with

| Eager Shortcut ->

transl_exp ~scopes e

| Eager Forward ->

Lprim (Pmakelazyblock Forward_tag,

[transl_exp ~scopes e],

of_location ~scopes e.exp_loc)

| Lazy_thunk ->

let fn = lfunction ~kind:Curried

~params:[Ident.create_local "param", Pgenval]

~return:Pgenval

(* The translation of [e] may be a function, in

~attr:function_attribute_disallowing_arity_fusion

~loc:(of_location ~scopes e.exp_loc)

~body:(transl_exp ~scopes e) in

Lprim(Pmakelazyblock Lazy_tag, [fn],

of_location ~scopes e.exp_loc)

end

| Texp_object (cs, meths) ->

let cty = cs.cstr_type in

let cl = Ident.create_local "object" in

!transl_object ~scopes cl meths

{ cl_desc = Tcl_structure cs;

cl_loc = e.exp_loc;

cl_type = Cty_signature cty;

cl_env = e.exp_env;

cl_attributes = [];

}

| Texp_letop{let_; ands; param; body; partial} ->

event_after ~scopes e

(transl_letop ~scopes e.exp_loc e.exp_env let_ ands param body partial)

| Texp_unreachable ->

raise (Error (e.exp_loc, Unreachable_reached))

| Texp_struct_item (si, e) ->

match m.mod_desc with

Tmod_ident _ -> Alias

| Tmod_constraint (m,_,_,_) -> pure_module m

let transl_with_shape e =

let shape = Typeopt.value_kind e.exp_env e.exp_type in

transl_exp ~scopes e, shape

in

let expr = event_before ~scopes rhs (transl_exp ~scopes rhs) in

match guard with

| None -> expr

| Some cond ->

event_before ~scopes cond

match cont, c_cont with

| Some id1, Some id2 -> Llet(Alias, Pgenval, id2, Lvar id1, body)

| None, None

| Some _, None -> body

iter_exn_names Translprim.add_exception_ident c_lhs;

Misc.try_finally

(fun () -> c_lhs, transl_guard ~scopes c_guard c_rhs)

~always:(fun () ->

let patl_expr_list =

List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable)

patl_expr_list in

List.map (fun (patl, guard, expr) -> (patl, transl_guard ~scopes guard expr))

?(tailcall=Default_tailcall)

?(inlined = Default_inline)

?(specialised = Default_specialise)

lam sargs loc

=

let lapply funct args =

match funct with

Lsend(k, lmet, lobj, largs, _) ->

Lsend(k, lmet, lobj, largs @ args, loc)

| Levent(Lsend(k, lmet, lobj, largs, _), _) ->

Lsend(k, lmet, lobj, largs @ args, loc)

| Lapply ap ->

Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc}

| lexp ->

Lapply {

ap_loc=loc;

ap_func=lexp;

ap_args=args;

ap_tailcall=tailcall;

ap_inlined=inlined;

ap_specialised=specialised;

}

in

(* Build a function application.

let rec build_apply lam args = function

(Omitted (), optional) :: l ->

(* Out-of-order partial application; we will need to build a closure *)

let defs = ref [] in

let protect name lam =

match lam with

Lvar _ | Lconst _ -> lam

| _ ->

let id = Ident.create_local name in

defs := (id, lam) :: !defs;

Lvar id

in

(* If all arguments in [args] were optional, delay their application

let args, args' =

if List.for_all (fun (_,opt) -> opt) args then [], args

else args, []

in

let lam =

if args = [] then lam else lapply lam (List.rev_map fst args)

in

(* Evaluate the function, applied to the arguments in [args] *)

let handle = protect "func" lam in

(* Evaluate the arguments whose applications was delayed;

let args' =

List.map (fun (arg, opt) -> protect "arg" arg, opt) args'

in

(* Evaluate the remaining arguments;

let l =

List.map

(fun (arg, opt) -> Typedtree.map_apply_arg (protect "arg") arg, opt)

l

in

let id_arg = Ident.create_local "param" in

(* Process remaining arguments and build closure *)

let body =

match build_apply handle ((Lvar id_arg, optional)::args') l with

Lfunction{kind = Curried; params = ids; return; body; attr; loc}

when List.length ids < Lambda.max_arity () ->

lfunction ~kind:Curried ~params:((id_arg, Pgenval)::ids)

~return ~body ~attr ~loc

| body ->

lfunction ~kind:Curried ~params:[id_arg, Pgenval]

~return:Pgenval ~body

~attr:default_stub_attribute ~loc

in

(* Wrap "protected" definitions, starting from the left,

List.fold_right

(fun (id, lam) body -> Llet(Strict, Pgenval, id, lam, body))

!defs body

| (Arg arg, optional) :: l ->

build_apply lam ((arg, optional) :: args) l

| [] ->

lapply lam (List.rev_map fst args)

in

let transl_arg arg = Typedtree.map_apply_arg (transl_exp ~scopes) arg in

(build_apply lam [] (List.map (fun (l, arg) ->

transl_arg arg,

Btype.is_optional l)

sargs)

let return =

match body with

| Tfunction_body body ->

value_kind body.exp_env body.exp_type

| Tfunction_cases { cases = { c_rhs } :: _ } ->

value_kind c_rhs.exp_env c_rhs.exp_type

| Tfunction_cases { cases = [] } ->

(* With Camlp4/ppx, a pattern matching might be empty *)

Pgenval

in

(* Cases are eligible for flattening if they belong to the only param. *)

let eligible_cases =

match params, body with

| [], Tfunction_cases { cases; partial } ->

Some (cases, partial)

| [ { fp_kind = Tparam_pat pat; fp_partial } ], Tfunction_body body ->

let case =

{ c_lhs = pat; c_cont = None; c_guard = None; c_rhs = body }

in

Some ([ case ], fp_partial)

| _ -> None

in

match eligible_cases with

| Some (({ c_lhs = { pat_desc = Tpat_tuple pl } } :: _) as cases, partial)

when !Clflags.native_code

&& List.length pl <= (Lambda.max_arity ()) ->

begin try

let size = List.length pl in

let pats_expr_list =

List.map

(fun {c_lhs; c_guard; c_rhs} ->

(Matching.flatten_pattern size c_lhs, c_guard, c_rhs))

cases in

let kinds =

(* All the patterns might not share the same types. We must take the

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 ~scopes loc params

(transl_tupled_cases ~scopes pats_expr_list) partial)

with Matching.Cannot_flatten ->

transl_curried_function ~scopes loc return repr params body

end

let cases_param, body =

match body with

| Tfunction_body body ->

None, event_before ~scopes body (transl_exp ~scopes body)

| Tfunction_cases { cases; partial; param; loc = cases_loc } ->

let kind =

match cases with

| [] ->

(* With Camlp4/ppx, a pattern matching might be empty *)

Pgenval

| {c_lhs=pat} :: other_cases ->

(* All the patterns might not share the same types. We must take the

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

let body =

Matching.for_function ~scopes cases_loc repr (Lvar param)

(transl_cases ~scopes cases) partial

in

Some (param, kind), body

in

let body, params =

List.fold_right (fun fp (body, params) ->

let param = fp.fp_param in

let param_loc = fp.fp_loc in

match fp.fp_kind with

| Tparam_pat pat ->

let kind = value_kind pat.pat_env pat.pat_type in

let body =

Matching.for_function ~scopes param_loc None (Lvar param)

[ pat, body ]

fp.fp_partial

in

body, (param, kind) :: params

| Tparam_optional_default (pat, default_arg) ->

let default_arg =

event_before ~scopes default_arg (transl_exp ~scopes default_arg)

in

let body =

Matching.for_optional_arg_default

~scopes param_loc pat body ~default_arg ~param

in

(* The optional param is Pgenval as it's an option. *)

body, (param, Pgenval) :: params)

params

(body, Option.to_list cases_param)

in

(* chunk params according to Lambda.max_arity. If Lambda.max_arity = n and

let params, return, body =

match Misc.Stdlib.List.chunks_of (Lambda.max_arity ()) params with

| [] ->

Misc.fatal_error "attempted to translate a function with zero arguments"

| first_chunk :: rest_of_chunks ->

let body, return =

List.fold_right

(fun chunk (body, return) ->

let attr = function_attribute_disallowing_arity_fusion in

let loc = of_location ~scopes loc in

let body =

lfunction ~kind:Curried ~params:chunk ~return ~body ~attr ~loc

in

(* we return Pgenval (for a function) after the rightmost chunk. *)

body, Pgenval)

rest_of_chunks

(body, return)

in

first_chunk, return, body

in

let ((kind, params, return), body) =

event_function ~scopes e

(function repr ->

let params, body = fuse_method_arity params body in

transl_function_without_attributes ~scopes e.exp_loc repr params body)

in

let attr = function_attribute_disallowing_arity_fusion in

let loc = of_location ~scopes e.exp_loc in

let lam = lfunction ~kind ~params ~return ~body ~attr ~loc in

let attrs =

(* Collect attributes from the Pexp_newtype node for locally abstract types.

List.fold_left

(fun attrs (extra_exp, _, extra_attrs) ->

match extra_exp with

| Texp_newtype _ -> extra_attrs @ attrs

| (Texp_constraint _ | Texp_coerce _ | Texp_poly _) -> attrs)

e.exp_attributes e.exp_extra

in

let should_introduce_scope =

match expr.exp_desc with

| Texp_function _ -> true

| _ when in_structure -> true

| _ -> false in

match pat_bound_idents pat with

| (id :: _) when should_introduce_scope ->

transl_scoped_exp ~scopes:(enter_value_definition ~scopes id) expr

match rec_flag with

Nonrecursive ->

let rec transl = function

[] ->

fun body -> body

| {vb_pat=pat; vb_expr=expr; vb_rec_kind=_; vb_attributes=attr; vb_loc}

:: rem ->

let lam = transl_bound_exp ~scopes ~in_structure pat expr in

let lam = Translattribute.add_function_attributes lam vb_loc attr in

let mk_body = transl rem in

fun body ->

Matching.for_let ~scopes pat.pat_loc lam pat (mk_body body)

in transl pat_expr_list

| Recursive ->

let idlist =

List.map

(fun {vb_pat=pat} -> match pat.pat_desc with

Tpat_var (id,_,_) -> id

| _ -> assert false)

pat_expr_list in

let transl_case {vb_expr=expr; vb_attributes; vb_rec_kind = rkind;

vb_loc; vb_pat} id =

let def = transl_bound_exp ~scopes ~in_structure vb_pat expr in

let def =

Translattribute.add_function_attributes def vb_loc vb_attributes

in

( id, rkind, def ) in

let lam_bds = List.map2 transl_case pat_expr_list idlist in

let size = Array.length fields in

(* Determine if there are "enough" fields (only relevant if this is a

let no_init = match opt_init_expr with None -> true | _ -> false in

if no_init || size < Config.max_young_wosize

then begin

(* Allocate new record with given fields (and remaining fields

let init_id = Ident.create_local "init" in

let lv =

Array.mapi

(fun i (_, definition) ->

match definition with

| Kept (typ, mut) ->

let field_kind = value_kind env typ in

let access =

match repres with

Record_regular | Record_inlined _ ->

Pfield (i, maybe_pointer_type env typ, mut)

| Record_unboxed _ -> assert false

| Record_extension _ ->

Pfield (i + 1, maybe_pointer_type env typ, mut)

| Record_float -> Pfloatfield i in

Lprim(access, [Lvar init_id],

of_location ~scopes loc),

field_kind

| Overridden (_lid, expr) ->

let field_kind = value_kind expr.exp_env expr.exp_type in

transl_exp ~scopes expr, field_kind)

fields

in

let ll, shape = List.split (Array.to_list lv) in

let mut =

if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields

then Mutable

else Immutable in

let lam =

try