explicit: bool;

(** When [explicit = true], we have an ambiguity between

arguments: subterm_information list;

var: Ident.t;

offset: 'offset;

loc : Debuginfo.Scoped_location.t;

(** The type [Constr.t] represents a reified constructor with

type t = {

tag : int;

flag: Asttypes.mutable_flag;

shape : block_shape;

before: lambda list;

after: lambda list;

loc : Debuginfo.Scoped_location.t;

}

(** [apply constr e] plugs the expression [e] in the hole of the

val apply : t -> lambda -> lambda

(** [with_placeholder constr body] binds a placeholder

val with_placeholder : t -> (offset destination -> lambda) -> lambda

(** We may want to delay the application of a constructor to a later

val delay_impure : block_id:int -> t -> (t -> lambda) -> lambda

end = struct

type t = {

tag : int;

flag: Asttypes.mutable_flag;

shape : block_shape;

before: lambda list;

after: lambda list;

loc : Debuginfo.Scoped_location.t;

}

let apply constr t =

let block_args = List.append constr.before @@ t :: constr.after in

Lprim (Pmakeblock (constr.tag, constr.flag, constr.shape),

block_args, constr.loc)

let tmc_placeholder =

(* we choose a placeholder whose tagged representation will be

Lconst (Const_base (Const_int (0xBBBB / 2)))

let with_placeholder constr (body : offset destination -> lambda) =

let k_with_placeholder =

apply { constr with flag = Mutable } tmc_placeholder in

let placeholder_pos = List.length constr.before in

let placeholder_pos_lam = Lconst (Const_base (Const_int placeholder_pos)) in

let block_var = Ident.create_local "block" in

Llet (Strict, Pgenval, block_var, k_with_placeholder,

body {

var = block_var;

offset = Offset placeholder_pos_lam ;

loc = constr.loc;

})

let delay_impure : block_id:int -> t -> (t -> lambda) -> lambda =

let bind_list ~block_id ~arg_offset lambdas k =

let can_be_delayed =

(* Note that the delayed subterms will be used

function

| Lvar _ | Lconst _ -> true

| _ -> false in

let bindings, args =

lambdas

|> List.mapi (fun i lam ->

if can_be_delayed lam then (None, lam)

else begin

let v = Ident.create_local

(Printf.sprintf "block%d_arg%d" block_id (arg_offset + i)) in

(Some (v, lam), Lvar v)

end)

|> List.split in

let body = k args in

List.fold_right (fun binding body ->

match binding with

| None -> body

| Some (v, lam) -> Llet(Strict, Pgenval, v, lam, body)

) bindings body in

fun ~block_id constr body ->

bind_list ~block_id ~arg_offset:0 constr.before @@ fun vbefore ->

let arg_offset = List.length constr.before + 1 in

bind_list ~block_id ~arg_offset constr.after @@ fun vafter ->

body { constr with before = vbefore; after = vafter }

type 'a dps = tail:bool -> dst:offset destination -> 'a

(** A term parameterized over a destination. The [tail] argument

type 'a t

val make : lambda dps -> lambda t

val run : lambda t -> lambda dps

val delay_constructor : Constr.t -> lambda t -> lambda t

val lambda : lambda -> lambda t

val map : ('a -> 'b) -> 'a t -> 'b t

val pair : 'a t -> 'b t -> ('a * 'b) t

val unit : unit t

end = struct

type 'a dps = tail:bool -> dst:offset destination -> 'a

type 'a t = {

code : delayed:Constr.t list -> 'a dps;

delayed_use_count : int;

}

(** We want to optimize nested constructors, for example:

let write_to_dst dst delayed t =

assign_to_dst dst @@

List.fold_left (fun t constr -> Constr.apply constr t) t delayed

let lambda (v : lambda) : lambda t = {

code = (fun ~delayed ~tail:_ ~dst ->

write_to_dst dst delayed v

);

delayed_use_count = 1;

}

(** Create a new destination-passing-style term which is simply

let unit : unit t = {

code = (fun ~delayed:_ ~tail:_ ~dst:_ ->

()

);

delayed_use_count = 0;

}

let map (f : 'a -> 'b) (d : 'a t) : 'b t = {

code = (fun ~delayed ~tail ~dst ->

f @@ d.code ~delayed ~tail ~dst);

delayed_use_count = d.delayed_use_count;

}

let pair (da : 'a t) (db : 'b t) : ('a * 'b) t = {

code = (fun ~delayed ~tail ~dst ->

(da.code ~delayed ~tail ~dst, db.code ~delayed ~tail ~dst));

delayed_use_count =

da.delayed_use_count + db.delayed_use_count;

}

let run (d : 'a t) : 'a dps =

fun ~tail ~dst ->

d.code ~tail ~dst ~delayed:[]

let reify_delay (dps : lambda dps) : lambda t = {

code = (fun ~delayed ~tail ~dst ->

match delayed with

| [] -> dps ~tail ~dst

| x :: xs ->

Constr.with_placeholder x @@ fun new_dst ->

Lsequence (

write_to_dst dst xs (Lvar new_dst.var),

dps ~tail ~dst:new_dst)

);

delayed_use_count = 1;

}

let ensures_affine (d : lambda t) : lambda t =

if d.delayed_use_count <= 1 then

d

else

reify_delay (run d)

(** Ensures that the resulting term does not duplicate delayed

let make (dps : 'a dps) : 'a t =

reify_delay dps

let delay_constructor constr d =

let d = ensures_affine d in {

code = (fun ~delayed ~tail ~dst ->

let block_id = List.length delayed in

Constr.delay_impure ~block_id constr @@ fun constr ->

d.code ~tail ~dst ~delayed:(constr :: delayed));

delayed_use_count = d.delayed_use_count;

}

type 'a t = {

dps : 'a Dps.t;

direct : unit -> 'a;

tmc_calls : tmc_call_information list;

benefits_from_dps: bool;

explicit_tailcall_request: bool;

}

(**

let lambda (v : lambda) : lambda t = {

dps = Dps.lambda v;

direct = (fun () -> v);

tmc_calls = [];

benefits_from_dps = false;

explicit_tailcall_request = false;

}

let map f s = {

dps = Dps.map f s.dps;

direct = (fun () -> f (s.direct ()));

tmc_calls = s.tmc_calls;

benefits_from_dps = s.benefits_from_dps;

explicit_tailcall_request = s.explicit_tailcall_request;

}

(** Apply function [f] to the transformed term. *)

let direct (c : 'a t) : 'a =

c.direct ()

let dps (c : lambda t) ~tail ~dst =

Dps.run c.dps ~tail ~dst

let pair ((c1, c2) : 'a t * 'b t) : ('a * 'b) t = {

dps = Dps.pair c1.dps c2.dps;

direct = (fun () -> (c1.direct (), c2.direct ()));

tmc_calls =

c1.tmc_calls @ c2.tmc_calls;

benefits_from_dps =

c1.benefits_from_dps || c2.benefits_from_dps;

explicit_tailcall_request =

c1.explicit_tailcall_request || c2.explicit_tailcall_request;

}

let unit = {

dps = Dps.unit;

direct = (fun () -> ());

tmc_calls = [];

benefits_from_dps = false;

explicit_tailcall_request = false;

}

(* Remark: we could define [pure v] as [map (fun () -> v) unit],

module Syntax = struct

let (let+) a f = map f a

let (and+) a1 a2 = pair (a1, a2)

end

open Syntax

let option (c : 'a t option) : 'a option t =

match c with

| None -> let+ () = unit in None

| Some c -> let+ v = c in Some v

let rec list (c : 'a t list) : 'a list t =

match c with

| [] -> let+ () = unit in []

| c :: cs ->

let+ v = c

and+ vs = list cs

in v :: vs

(** The [find_*] machinery is used to locate a single subterm to

type 'a tmc_call_search =

| No_tmc_call of 'a list

| Nonambiguous of 'a zipper

| Ambiguous of { explicit: bool; subterms: 'a t list; }

and 'a zipper = {

rev_before : 'a list;

choice : 'a t;

after: 'a list

}

let find_nonambiguous_tmc_call choices =

let has_tmc_calls c = c.tmc_calls <> [] in

let is_explicit s = s.explicit_tailcall_request in

let nonambiguous ~only_explicit_calls choices =

(* here is how we will compute the result once we know that there

let rec split rev_before : 'a t list -> 'a zipper = function

| [] -> assert false (* we know there is at least one choice *)

| c :: rest ->

if has_tmc_calls c && (not only_explicit_calls || is_explicit c) then

{ rev_before; choice = c; after = List.map direct rest }

else

split (direct c :: rev_before) rest

in split [] choices

in

let tmc_call_subterms =

List.filter (fun c -> has_tmc_calls c) choices

in

match tmc_call_subterms with

| [] ->

No_tmc_call (List.map direct choices)

| [ _one ] ->

Nonambiguous (nonambiguous ~only_explicit_calls:false choices)

| several_subterms ->

let explicit_subterms = List.filter is_explicit several_subterms in

begin match explicit_subterms with

| [] ->

Ambiguous {

explicit = false;

subterms = several_subterms;

}

| [ _one ] ->

Nonambiguous (nonambiguous ~only_explicit_calls:true choices)

| several_explicit_subterms ->

Ambiguous {

explicit = true;

subterms = several_explicit_subterms;

}

end

arity: int;

dps_id: Ident.t;

direct_kind: function_kind;

match find_candidate def with

| None -> ctx

| Some lfun ->

let arity = List.length lfun.params in

let dps_id = Ident.create_local (Ident.name var ^ "_dps") in

let direct_kind = lfun.kind in

let cand = { arity; dps_id; direct_kind; } in

let rec choice ctx ~tail t =

match t with

| (Lvar _ | Lmutvar _ | Lconst _ | Lfunction _ | Lsend _

| Lassign _ | Lfor _ | Lwhile _) ->

let t = traverse ctx t in

Choice.lambda t

(* [choice_prim] handles most primitives, but the important case

| Lprim (prim, primargs, loc) ->

choice_prim ctx ~tail prim primargs loc

(* [choice_apply] handles applications, in particular tail-calls which

| Lapply apply ->

choice_apply ctx ~tail apply

(* other cases use the [lift] helper that takes the sub-terms in tail

| Lsequence (l1, l2) ->

let l1 = traverse ctx l1 in

let+ l2 = choice ctx ~tail l2 in

Lsequence (l1, l2)

| Lifthenelse (l1, l2, l3) ->

let l1 = traverse ctx l1 in

let+ (l2, l3) = choice_pair ctx ~tail (l2, l3) in

Lifthenelse (l1, l2, l3)

| Lmutlet (vk, var, def, body) ->

(* mutable bindings are not TMC-specialized *)

let def = traverse ctx def in

let+ body = choice ctx ~tail body in

Lmutlet (vk, var, def, body)

| Llet (lk, vk, var, def, body) ->

let ctx, bindings = traverse_let ctx var def in

let+ body = choice ctx ~tail body in

llets lk vk bindings body

| Lletrec (bindings, body) ->

let ctx, bindings = traverse_letrec ctx bindings in

let+ body = choice ctx ~tail body in

Lletrec(bindings, body)

| Lswitch (l1, sw, loc) ->

(* decompose *)

let consts_lhs, consts_rhs = List.split sw.sw_consts in

let blocks_lhs, blocks_rhs = List.split sw.sw_blocks in

(* transform *)

let l1 = traverse ctx l1 in

let+ consts_rhs = choice_list ctx ~tail consts_rhs

and+ blocks_rhs = choice_list ctx ~tail blocks_rhs

and+ sw_failaction = choice_option ctx ~tail sw.sw_failaction in

(* rebuild *)

let sw_consts = List.combine consts_lhs consts_rhs in

let sw_blocks = List.combine blocks_lhs blocks_rhs in

let sw = { sw with sw_consts; sw_blocks; sw_failaction; } in

Lswitch (l1, sw, loc)

| Lstringswitch (l1, cases, fail, loc) ->

(* decompose *)

let cases_lhs, cases_rhs = List.split cases in

(* transform *)

let l1 = traverse ctx l1 in

let+ cases_rhs = choice_list ctx ~tail cases_rhs

and+ fail = choice_option ctx ~tail fail in

(* rebuild *)

let cases = List.combine cases_lhs cases_rhs in

Lstringswitch (l1, cases, fail, loc)

| Lstaticraise (id, ls) ->

let ls = traverse_list ctx ls in

Choice.lambda (Lstaticraise (id, ls))

| Ltrywith (l1, id, l2) ->

(* in [try l1 with id -> l2], the term [l1] is

let l1 = traverse ctx l1 in

let+ l2 = choice ctx ~tail l2 in

Ltrywith (l1, id, l2)

| Lstaticcatch (l1, ids, l2) ->

(* In [static-catch l1 with ids -> l2],

let+ l1 = choice ctx ~tail l1

and+ l2 = choice ctx ~tail l2 in

Lstaticcatch (l1, ids, l2)

| Levent (lam, lev) ->

let+ lam = choice ctx ~tail lam in

Levent (lam, lev)

| Lifused (x, lam) ->

let+ lam = choice ctx ~tail lam in

Lifused (x, lam)

and choice_apply ctx ~tail apply =

let exception No_tmc in

try

let explicit_tailcall_request =

match apply.ap_tailcall with

| Default_tailcall -> false

| Tailcall_expectation true -> true

| Tailcall_expectation false -> raise No_tmc

in

match apply.ap_func with

| Lvar f ->

let specialized =

try Ident.Map.find f ctx.specialized

with Not_found ->

if tail then

Location.prerr_warning

(Debuginfo.Scoped_location.to_location apply.ap_loc)

Warnings.Tmc_breaks_tailcall;

raise No_tmc;

in

let args =

(* Support of tupled functions: the [function_kind] of the

let kind, arity = specialized.direct_kind, specialized.arity in

match Lambda.find_exact_application kind ~arity apply.ap_args with

| None -> raise No_tmc

| Some args -> args

in

let tailcall tail =

(* If we are calling a tmc-specializable function in tail

if tail

then Tailcall_expectation true

else Default_tailcall

in

{

Choice.dps = Dps.make (fun ~tail ~dst ->

Lapply { apply with

ap_func = Lvar specialized.dps_id;

ap_args = add_dst_args dst args;

ap_tailcall = tailcall tail;

});

direct = (fun () ->

Lapply { apply with ap_tailcall = tailcall tail });

explicit_tailcall_request;

tmc_calls = [{

loc = apply.ap_loc;

explicit = explicit_tailcall_request;

}];

benefits_from_dps = true;

}

| _nontail -> raise No_tmc

with No_tmc ->

let apply_no_bailout =

(* [@tailcall false] is interpreted as a bailout annotation: "we

let ap_tailcall =

match apply.ap_tailcall with

| Tailcall_expectation false when tail -> Default_tailcall

| other -> other

in

{ apply with ap_tailcall } in

{ (Choice.lambda (Lapply apply)) with

direct = (fun () -> Lapply apply_no_bailout);

}

and choice_makeblock ctx ~tail:_ (tag, flag, shape) blockargs loc =

let choices = List.map (choice ctx ~tail:false) blockargs in

match Choice.find_nonambiguous_tmc_call choices with

| Choice.No_tmc_call args ->

Choice.lambda @@ Lprim (Pmakeblock (tag, flag, shape), args, loc)

| Choice.Ambiguous { explicit; subterms = ambiguous_subterms } ->

(* An ambiguous term should not lead to an error if it not

let term_choice =

let+ args = Choice.list choices in

Lprim (Pmakeblock(tag, flag, shape), args, loc)

in

{ term_choice with

Choice.dps = Dps.make (fun ~tail:_ ~dst:_ ->

let arguments =

let info (t : lambda Choice.t) : subterm_information = {

tmc_calls = t.tmc_calls;

} in

{

explicit;

arguments = List.map info ambiguous_subterms;

}

in

raise (Error (Debuginfo.Scoped_location.to_location loc,

Ambiguous_constructor_arguments arguments))

);

}

| Choice.Nonambiguous { Choice.rev_before; choice; after } ->

let constr = Constr.{

tag;

flag;

shape;

before = List.rev rev_before;

after;

loc;

} in

assert (choice.tmc_calls <> []);

{

Choice.direct = (fun () ->

if not choice.benefits_from_dps then

Constr.apply constr (Choice.direct choice)

else

Constr.with_placeholder constr @@ fun new_dst ->

Lsequence(Choice.dps choice ~tail:false ~dst:new_dst,

Lvar new_dst.var));

benefits_from_dps =

(* Whether or not the caller provides a destination,

false;

dps = Dps.delay_constructor constr choice.dps;

tmc_calls =

choice.tmc_calls;

explicit_tailcall_request =

choice.explicit_tailcall_request;

}

and choice_prim ctx ~tail prim primargs loc =

match prim with

(* The important case is the construction case *)

| Pmakeblock (tag, flag, shape) ->

choice_makeblock ctx ~tail (tag, flag, shape) primargs loc

(* Some primitives have arguments in tail-position *)

| Popaque ->

let l1 = match primargs with

| [l1] -> l1

| _ -> invalid_arg "choice_prim" in

let+ l1 = choice ctx ~tail l1 in

Lprim (Popaque, [l1], loc)

| (Psequand | Psequor) as shortcutop ->

let l1, l2 = match primargs with

| [l1; l2] -> l1, l2

| _ -> invalid_arg "choice_prim" in

let l1 = traverse ctx l1 in

let+ l2 = choice ctx ~tail l2 in

Lprim (shortcutop, [l1; l2], loc)

(* in common cases we just return *)

| Pbytes_to_string | Pbytes_of_string

| Pgetglobal _ | Psetglobal _

| Pfield _ | Pfield_computed

| Psetfield _ | Psetfield_computed _

| Pfloatfield _ | Psetfloatfield _

| Pccall _

| Praise _

| Pnot

| Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _

| Pandint | Porint | Pxorint

| Plslint | Plsrint | Pasrint

| Pintcomp _

| Poffsetint _ | Poffsetref _

| Pintoffloat | Pfloatofint

| Pnegfloat | Pabsfloat

| Paddfloat | Psubfloat | Pmulfloat | Pdivfloat

| Pfloatcomp _

| Pstringlength | Pstringrefu | Pstringrefs

| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets

| Parraylength _ | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _

| Pisint | Pisout

| Pignore

| Pcompare_ints | Pcompare_floats | Pcompare_bints _

(* we don't handle effect or DLS primitives *)

| Prunstack | Pperform | Presume | Preperform | Pdls_get

(* we don't handle atomic primitives *)

| Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _

(* we don't handle array indices as destinations yet *)

| (Pmakearray _ | Pduparray _)

(* we don't handle { foo with x = ...; y = recursive-call } *)

| Pduprecord _

(* operations returning boxed values could be considered

| Pbintofint _ | Pintofbint _

| Pcvtbint _

| Pnegbint _

| Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _

| Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _

| Pbintcomp _

(* more common cases... *)

| Pbigarrayref _ | Pbigarrayset _

| Pbigarraydim _

| Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _

| Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _

| Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _

| Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _

| Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _

| Pctconst _

| Pbswap16

| Pbbswap _

| Pint_as_pointer

->

let primargs = traverse_list ctx primargs in

Choice.lambda (Lprim (prim, primargs, loc))

and choice_list ctx ~tail terms =

Choice.list (List.map (choice ctx ~tail) terms)

and choice_pair ctx ~tail (t1, t2) =

Choice.pair (choice ctx ~tail t1, choice ctx ~tail t2)

and choice_option ctx ~tail t =

Choice.option (Option.map (choice ctx ~tail) t)

| Llet (lk, vk, var, def, body) ->

let ctx, bindings = traverse_let ctx var def in

let body = traverse ctx body in

llets lk vk bindings body

| Lletrec (bindings, body) ->

let ctx, bindings = traverse_letrec ctx bindings in

Lletrec (bindings, traverse ctx body)

| lam ->

match find_candidate def with

| None -> [(var, traverse outer_ctx def)]

| Some lfun ->

let special = Ident.Map.find var inner_ctx.specialized in

let fun_choice = choice outer_ctx ~tail:true lfun.body in

if fun_choice.Choice.tmc_calls = [] then

Location.prerr_warning

(Debuginfo.Scoped_location.to_location lfun.loc)

Warnings.Unused_tmc_attribute;

let direct =

Lfunction { lfun with body = Choice.direct fun_choice } in

let dps =

let dst_param = {

var = Ident.create_local "dst";

offset = Ident.create_local "offset";

loc = lfun.loc;

} in

let dst = { dst_param with offset = Offset (Lvar dst_param.offset) } in

Lambda.duplicate @@ Lfunction { lfun with

kind =

(* Support of Tupled function: see [choice_apply]. *)

Curried;

params = add_dst_params dst_param lfun.params;

body = Choice.dps ~tail:true ~dst:dst fun_choice;

} in

let dps_var = special.dps_id in

Format.pp_print_text ppf

"[@tail_mod_cons]: this constructor application may be \