759 lines
28 KiB
OCaml
759 lines
28 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Pierre Chambart, OCamlPro *)
|
|
(* Mark Shinwell and Leo White, Jane Street Europe *)
|
|
(* *)
|
|
(* Copyright 2013--2016 OCamlPro SAS *)
|
|
(* Copyright 2014--2016 Jane Street Group LLC *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
[@@@ocaml.warning "+a-4-30-40-41-42"]
|
|
|
|
(* We say that an [Ident.t] is "linear" iff:
|
|
(a) it is used exactly once;
|
|
(b) it is never assigned to (using [Uassign]).
|
|
*)
|
|
type ident_info =
|
|
{ used : Ident.Set.t;
|
|
linear : Ident.Set.t;
|
|
assigned : Ident.Set.t;
|
|
closure_environment : Ident.Set.t;
|
|
let_bound_vars_that_can_be_moved : Ident.Set.t;
|
|
}
|
|
|
|
let ignore_uconstant (_ : Clambda.uconstant) = ()
|
|
let ignore_ulambda (_ : Clambda.ulambda) = ()
|
|
let ignore_ulambda_list (_ : Clambda.ulambda list) = ()
|
|
let ignore_function_label (_ : Clambda.function_label) = ()
|
|
let ignore_debuginfo (_ : Debuginfo.t) = ()
|
|
let ignore_int (_ : int) = ()
|
|
let ignore_ident (_ : Ident.t) = ()
|
|
let ignore_primitive (_ : Lambda.primitive) = ()
|
|
let ignore_string (_ : string) = ()
|
|
let ignore_int_array (_ : int array) = ()
|
|
let ignore_ident_list (_ : Ident.t list) = ()
|
|
let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
|
|
let ignore_meth_kind (_ : Lambda.meth_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
|
|
module). *)
|
|
|
|
let closure_environment_ident (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
|
|
assert(Ident.name env_var = "env");
|
|
Some env_var
|
|
else
|
|
(* closed function, no environment *)
|
|
None
|
|
|
|
let make_ident_info (clam : Clambda.ulambda) : ident_info =
|
|
let t : int Ident.Tbl.t = Ident.Tbl.create 42 in
|
|
let assigned_idents = ref Ident.Set.empty in
|
|
let environment_idents = ref Ident.Set.empty in
|
|
let rec loop : Clambda.ulambda -> unit = function
|
|
(* No underscores in the pattern match, to reduce the chance of failing
|
|
to traverse some subexpression. *)
|
|
| Uvar id ->
|
|
begin match Ident.Tbl.find t id with
|
|
| n -> Ident.Tbl.replace t id (n + 1)
|
|
| exception Not_found -> Ident.Tbl.add t id 1
|
|
end
|
|
| Uconst const ->
|
|
(* The only variables that might occur in [const] are those in constant
|
|
closures---and those are all bound by such closures. It follows that
|
|
[const] cannot contain any variables that are bound in the current
|
|
scope, so we do not need to count them here. (The function bodies
|
|
of the closures will be traversed when this function is called from
|
|
[Cmmgen.transl_function].) *)
|
|
ignore_uconstant const
|
|
| Udirect_apply (label, args, dbg) ->
|
|
ignore_function_label label;
|
|
List.iter loop args;
|
|
ignore_debuginfo dbg
|
|
| Ugeneric_apply (func, args, dbg) ->
|
|
loop func;
|
|
List.iter loop args;
|
|
ignore_debuginfo dbg
|
|
| Uclosure (functions, captured_variables) ->
|
|
List.iter loop captured_variables;
|
|
List.iter (fun ({ Clambda. label; arity; params; body; dbg } as clos) ->
|
|
(match closure_environment_ident clos with
|
|
| None -> ()
|
|
| Some env_var ->
|
|
environment_idents :=
|
|
Ident.Set.add env_var !environment_idents);
|
|
ignore_function_label label;
|
|
ignore_int arity;
|
|
ignore_ident_list params;
|
|
loop body;
|
|
ignore_debuginfo dbg)
|
|
functions
|
|
| Uoffset (expr, offset) ->
|
|
loop expr;
|
|
ignore_int offset
|
|
| Ulet (_let_kind, _value_kind, _ident, def, body) ->
|
|
loop def;
|
|
loop body
|
|
| Uletrec (defs, body) ->
|
|
List.iter (fun (ident, def) ->
|
|
ignore_ident ident;
|
|
loop def)
|
|
defs;
|
|
loop body
|
|
| Uprim (prim, args, dbg) ->
|
|
ignore_primitive prim;
|
|
List.iter loop args;
|
|
ignore_debuginfo dbg
|
|
| Uswitch (cond, { us_index_consts; us_actions_consts;
|
|
us_index_blocks; us_actions_blocks }) ->
|
|
loop cond;
|
|
ignore_int_array us_index_consts;
|
|
Array.iter loop us_actions_consts;
|
|
ignore_int_array us_index_blocks;
|
|
Array.iter loop us_actions_blocks
|
|
| Ustringswitch (cond, branches, default) ->
|
|
loop cond;
|
|
List.iter (fun (str, branch) ->
|
|
ignore_string str;
|
|
loop branch)
|
|
branches;
|
|
Misc.may loop default
|
|
| Ustaticfail (static_exn, args) ->
|
|
ignore_int static_exn;
|
|
List.iter loop args
|
|
| Ucatch (static_exn, idents, body, handler) ->
|
|
ignore_int static_exn;
|
|
ignore_ident_list idents;
|
|
loop body;
|
|
loop handler
|
|
| Utrywith (body, ident, handler) ->
|
|
loop body;
|
|
ignore_ident ident;
|
|
loop handler
|
|
| Uifthenelse (cond, ifso, ifnot) ->
|
|
loop cond;
|
|
loop ifso;
|
|
loop ifnot
|
|
| Usequence (e1, e2) ->
|
|
loop e1;
|
|
loop e2
|
|
| Uwhile (cond, body) ->
|
|
loop cond;
|
|
loop body
|
|
| Ufor (ident, low, high, direction_flag, body) ->
|
|
ignore_ident ident;
|
|
loop low;
|
|
loop high;
|
|
ignore_direction_flag direction_flag;
|
|
loop body
|
|
| Uassign (ident, expr) ->
|
|
assigned_idents := Ident.Set.add ident !assigned_idents;
|
|
loop expr
|
|
| Usend (meth_kind, e1, e2, args, dbg) ->
|
|
ignore_meth_kind meth_kind;
|
|
loop e1;
|
|
loop e2;
|
|
List.iter loop args;
|
|
ignore_debuginfo dbg
|
|
| Uunreachable ->
|
|
()
|
|
in
|
|
loop clam;
|
|
let linear =
|
|
Ident.Tbl.fold (fun id n acc ->
|
|
assert (n >= 1);
|
|
if n = 1 && not (Ident.Set.mem id !assigned_idents)
|
|
then Ident.Set.add id acc
|
|
else acc)
|
|
t Ident.Set.empty
|
|
in
|
|
let assigned = !assigned_idents in
|
|
let used =
|
|
(* This doesn't work transitively and thus is somewhat restricted. In
|
|
particular, it does not allow us to get rid of useless chains of [let]s.
|
|
However it should be sufficient to remove the majority of unnecessary
|
|
[let] bindings that might hinder [Cmmgen]. *)
|
|
Ident.Tbl.fold (fun id _n acc -> Ident.Set.add id acc)
|
|
t assigned
|
|
in
|
|
{ used; linear; assigned; closure_environment = !environment_idents;
|
|
let_bound_vars_that_can_be_moved = Ident.Set.empty;
|
|
}
|
|
|
|
(* When sequences of [let]-bindings match the evaluation order in a subsequent
|
|
primitive or function application whose arguments are linearly-used
|
|
non-assigned variables bound by such lets (possibly interspersed with other
|
|
variables that are known to be constant), and it is known that there were no
|
|
intervening side-effects during the evaluation of the [let]-bindings,
|
|
permit substitution of the variables for their defining expressions. *)
|
|
let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) =
|
|
let obviously_constant = ref Ident.Set.empty in
|
|
let can_move = ref Ident.Set.empty in
|
|
let let_stack = ref [] in
|
|
let examine_argument_list args =
|
|
let rec loop let_bound_vars (args : Clambda.ulambda list) =
|
|
match let_bound_vars, args with
|
|
| _, [] ->
|
|
(* We've matched all arguments and will not substitute (in the
|
|
current application being considered) any of the remaining
|
|
[let_bound_vars]. As such they may stay on the stack. *)
|
|
let_bound_vars
|
|
| [], _ ->
|
|
(* There are no more [let]-bindings to consider, so the stack
|
|
is left empty. *)
|
|
[]
|
|
| let_bound_vars, (Uvar arg)::args
|
|
when Ident.Set.mem arg !obviously_constant ->
|
|
loop let_bound_vars args
|
|
| let_bound_var::let_bound_vars, (Uvar arg)::args
|
|
when Ident.same let_bound_var arg
|
|
&& not (Ident.Set.mem arg ident_info.assigned) ->
|
|
assert (Ident.Set.mem arg ident_info.used);
|
|
assert (Ident.Set.mem arg ident_info.linear);
|
|
can_move := Ident.Set.add arg !can_move;
|
|
loop let_bound_vars args
|
|
| _::_, _::_ ->
|
|
(* The [let] sequence has ceased to match the evaluation order
|
|
or we have encountered some complicated argument. In this case
|
|
we empty the stack to ensure that we do not end up moving an
|
|
outer [let] across a side effect. *)
|
|
[]
|
|
in
|
|
(* Start at the most recent let binding and the leftmost argument
|
|
(the last argument to be evaluated). *)
|
|
let_stack := loop !let_stack args
|
|
in
|
|
let rec loop : Clambda.ulambda -> unit = function
|
|
| Uvar ident ->
|
|
if Ident.Set.mem ident ident_info.assigned then begin
|
|
let_stack := []
|
|
end
|
|
| Uconst const ->
|
|
ignore_uconstant const
|
|
| Udirect_apply (label, args, dbg) ->
|
|
ignore_function_label label;
|
|
examine_argument_list args;
|
|
(* We don't currently traverse [args]; they should all be variables
|
|
anyway. If this is added in the future, take care to traverse [args]
|
|
following the evaluation order. *)
|
|
ignore_debuginfo dbg
|
|
| Ugeneric_apply (func, args, dbg) ->
|
|
examine_argument_list (args @ [func]);
|
|
ignore_debuginfo dbg
|
|
| 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; } ->
|
|
ignore_function_label label;
|
|
ignore_int arity;
|
|
ignore_ident_list params;
|
|
let_stack := [];
|
|
loop body;
|
|
let_stack := [];
|
|
ignore_debuginfo dbg)
|
|
functions
|
|
| Uoffset (expr, offset) ->
|
|
(* [expr] should usually be a variable. *)
|
|
examine_argument_list [expr];
|
|
ignore_int offset
|
|
| Ulet (_let_kind, _value_kind, ident, def, body) ->
|
|
begin match def with
|
|
| Uconst _ ->
|
|
(* The defining expression is obviously constant, so we don't
|
|
have to put this [let] on the stack, and we don't have to
|
|
traverse the defining expression either. *)
|
|
obviously_constant := Ident.Set.add ident !obviously_constant;
|
|
loop body
|
|
| _ ->
|
|
loop def;
|
|
if Ident.Set.mem ident ident_info.linear then begin
|
|
let_stack := ident::!let_stack
|
|
end else begin
|
|
(* If we encounter a non-linear [let]-binding then we must clear
|
|
the let stack, since we cannot now move any previous binding
|
|
across the non-linear one. *)
|
|
let_stack := []
|
|
end;
|
|
loop body
|
|
end
|
|
| Uletrec (defs, body) ->
|
|
(* Evaluation order for [defs] is not defined, and this case
|
|
probably isn't important for [Cmmgen] anyway. *)
|
|
let_stack := [];
|
|
List.iter (fun (ident, def) ->
|
|
ignore_ident ident;
|
|
loop def;
|
|
let_stack := [])
|
|
defs;
|
|
loop body
|
|
| Uprim (prim, args, dbg) ->
|
|
ignore_primitive prim;
|
|
examine_argument_list args;
|
|
ignore_debuginfo dbg
|
|
| Uswitch (cond, { us_index_consts; us_actions_consts;
|
|
us_index_blocks; us_actions_blocks }) ->
|
|
examine_argument_list [cond];
|
|
ignore_int_array us_index_consts;
|
|
Array.iter (fun action ->
|
|
let_stack := [];
|
|
loop action)
|
|
us_actions_consts;
|
|
ignore_int_array us_index_blocks;
|
|
Array.iter (fun action ->
|
|
let_stack := [];
|
|
loop action)
|
|
us_actions_blocks;
|
|
let_stack := []
|
|
| Ustringswitch (cond, branches, default) ->
|
|
examine_argument_list [cond];
|
|
List.iter (fun (str, branch) ->
|
|
ignore_string str;
|
|
let_stack := [];
|
|
loop branch)
|
|
branches;
|
|
let_stack := [];
|
|
Misc.may loop default;
|
|
let_stack := []
|
|
| Ustaticfail (static_exn, args) ->
|
|
ignore_int static_exn;
|
|
ignore_ulambda_list args;
|
|
let_stack := []
|
|
| Ucatch (static_exn, idents, body, handler) ->
|
|
ignore_int static_exn;
|
|
ignore_ident_list idents;
|
|
let_stack := [];
|
|
loop body;
|
|
let_stack := [];
|
|
loop handler;
|
|
let_stack := []
|
|
| Utrywith (body, ident, handler) ->
|
|
let_stack := [];
|
|
loop body;
|
|
let_stack := [];
|
|
ignore_ident ident;
|
|
loop handler;
|
|
let_stack := []
|
|
| Uifthenelse (cond, ifso, ifnot) ->
|
|
examine_argument_list [cond];
|
|
let_stack := [];
|
|
loop ifso;
|
|
let_stack := [];
|
|
loop ifnot;
|
|
let_stack := []
|
|
| Usequence (e1, e2) ->
|
|
loop e1;
|
|
let_stack := [];
|
|
loop e2;
|
|
let_stack := []
|
|
| Uwhile (cond, body) ->
|
|
let_stack := [];
|
|
loop cond;
|
|
let_stack := [];
|
|
loop body;
|
|
let_stack := []
|
|
| Ufor (ident, low, high, direction_flag, body) ->
|
|
ignore_ident ident;
|
|
(* Cmmgen generates code that evaluates low before high,
|
|
but we don't do anything here at the moment anyway. *)
|
|
ignore_ulambda low;
|
|
ignore_ulambda high;
|
|
ignore_direction_flag direction_flag;
|
|
let_stack := [];
|
|
loop body;
|
|
let_stack := []
|
|
| Uassign (ident, expr) ->
|
|
ignore_ident ident;
|
|
ignore_ulambda expr;
|
|
let_stack := []
|
|
| Usend (meth_kind, e1, e2, args, dbg) ->
|
|
ignore_meth_kind meth_kind;
|
|
ignore_ulambda e1;
|
|
ignore_ulambda e2;
|
|
ignore_ulambda_list args;
|
|
let_stack := [];
|
|
ignore_debuginfo dbg
|
|
| Uunreachable ->
|
|
let_stack := []
|
|
in
|
|
loop clam;
|
|
!can_move
|
|
|
|
(* Substitution of an expression for a let-moveable variable can cause the
|
|
surrounding expression to become fixed. To avoid confusion, do the
|
|
let-moveable substitutions first. *)
|
|
let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda)
|
|
: Clambda.ulambda =
|
|
match clam with
|
|
| Uvar id ->
|
|
if not (Ident.Set.mem id is_let_moveable) then
|
|
clam
|
|
else
|
|
begin match Ident.Map.find id env with
|
|
| clam -> clam
|
|
| exception Not_found ->
|
|
Misc.fatal_errorf "substitute_let_moveable: Unbound identifier %a"
|
|
Ident.print id
|
|
end
|
|
| Uconst _ -> clam
|
|
| Udirect_apply (label, args, dbg) ->
|
|
let args = substitute_let_moveable_list is_let_moveable env args in
|
|
Udirect_apply (label, args, dbg)
|
|
| Ugeneric_apply (func, args, dbg) ->
|
|
let func = substitute_let_moveable is_let_moveable env func in
|
|
let args = substitute_let_moveable_list is_let_moveable env args in
|
|
Ugeneric_apply (func, args, dbg)
|
|
| Uclosure (functions, variables_bound_by_the_closure) ->
|
|
let functions =
|
|
List.map (fun (ufunction : Clambda.ufunction) ->
|
|
{ ufunction with
|
|
body = substitute_let_moveable is_let_moveable env ufunction.body;
|
|
})
|
|
functions
|
|
in
|
|
let variables_bound_by_the_closure =
|
|
substitute_let_moveable_list is_let_moveable env
|
|
variables_bound_by_the_closure
|
|
in
|
|
Uclosure (functions, variables_bound_by_the_closure)
|
|
| Uoffset (clam, n) ->
|
|
let clam = substitute_let_moveable is_let_moveable env clam in
|
|
Uoffset (clam, n)
|
|
| Ulet (let_kind, value_kind, id, def, body) ->
|
|
let def = substitute_let_moveable is_let_moveable env def in
|
|
if Ident.Set.mem id is_let_moveable then
|
|
let env = Ident.Map.add id def env in
|
|
substitute_let_moveable is_let_moveable env body
|
|
else
|
|
Ulet (let_kind, value_kind,
|
|
id, def, substitute_let_moveable is_let_moveable env body)
|
|
| Uletrec (defs, body) ->
|
|
let defs =
|
|
List.map (fun (id, def) ->
|
|
id, substitute_let_moveable is_let_moveable env def)
|
|
defs
|
|
in
|
|
let body = substitute_let_moveable is_let_moveable env body in
|
|
Uletrec (defs, body)
|
|
| Uprim (prim, args, dbg) ->
|
|
let args = substitute_let_moveable_list is_let_moveable env args in
|
|
Uprim (prim, args, dbg)
|
|
| Uswitch (cond, sw) ->
|
|
let cond = substitute_let_moveable is_let_moveable env cond in
|
|
let sw =
|
|
{ sw with
|
|
us_actions_consts =
|
|
substitute_let_moveable_array is_let_moveable env
|
|
sw.us_actions_consts;
|
|
us_actions_blocks =
|
|
substitute_let_moveable_array is_let_moveable env
|
|
sw.us_actions_blocks;
|
|
}
|
|
in
|
|
Uswitch (cond, sw)
|
|
| Ustringswitch (cond, branches, default) ->
|
|
let cond = substitute_let_moveable is_let_moveable env cond in
|
|
let branches =
|
|
List.map (fun (s, branch) ->
|
|
s, substitute_let_moveable is_let_moveable env branch)
|
|
branches
|
|
in
|
|
let default =
|
|
Misc.may_map (substitute_let_moveable is_let_moveable env) default
|
|
in
|
|
Ustringswitch (cond, branches, default)
|
|
| Ustaticfail (n, args) ->
|
|
let args = substitute_let_moveable_list is_let_moveable env args in
|
|
Ustaticfail (n, args)
|
|
| Ucatch (n, ids, body, handler) ->
|
|
let body = substitute_let_moveable is_let_moveable env body in
|
|
let handler = substitute_let_moveable is_let_moveable env handler in
|
|
Ucatch (n, ids, body, handler)
|
|
| Utrywith (body, id, handler) ->
|
|
let body = substitute_let_moveable is_let_moveable env body in
|
|
let handler = substitute_let_moveable is_let_moveable env handler in
|
|
Utrywith (body, id, handler)
|
|
| Uifthenelse (cond, ifso, ifnot) ->
|
|
let cond = substitute_let_moveable is_let_moveable env cond in
|
|
let ifso = substitute_let_moveable is_let_moveable env ifso in
|
|
let ifnot = substitute_let_moveable is_let_moveable env ifnot in
|
|
Uifthenelse (cond, ifso, ifnot)
|
|
| Usequence (e1, e2) ->
|
|
let e1 = substitute_let_moveable is_let_moveable env e1 in
|
|
let e2 = substitute_let_moveable is_let_moveable env e2 in
|
|
Usequence (e1, e2)
|
|
| Uwhile (cond, body) ->
|
|
let cond = substitute_let_moveable is_let_moveable env cond in
|
|
let body = substitute_let_moveable is_let_moveable env body in
|
|
Uwhile (cond, body)
|
|
| Ufor (id, low, high, direction, body) ->
|
|
let low = substitute_let_moveable is_let_moveable env low in
|
|
let high = substitute_let_moveable is_let_moveable env high in
|
|
let body = substitute_let_moveable is_let_moveable env body in
|
|
Ufor (id, low, high, direction, body)
|
|
| Uassign (id, expr) ->
|
|
let expr = substitute_let_moveable is_let_moveable env expr in
|
|
Uassign (id, expr)
|
|
| Usend (kind, e1, e2, args, dbg) ->
|
|
let e1 = substitute_let_moveable is_let_moveable env e1 in
|
|
let e2 = substitute_let_moveable is_let_moveable env e2 in
|
|
let args = substitute_let_moveable_list is_let_moveable env args in
|
|
Usend (kind, e1, e2, args, dbg)
|
|
| Uunreachable ->
|
|
Uunreachable
|
|
|
|
and substitute_let_moveable_list is_let_moveable env clams =
|
|
List.map (substitute_let_moveable is_let_moveable env) clams
|
|
|
|
and substitute_let_moveable_array is_let_moveable env clams =
|
|
Array.map (substitute_let_moveable is_let_moveable env) clams
|
|
|
|
(* We say that an expression is "moveable" iff it has neither effects nor
|
|
coeffects. (See semantics_of_primitives.mli.)
|
|
*)
|
|
type moveable = Fixed | Moveable | Moveable_not_into_loops
|
|
|
|
let both_moveable a b =
|
|
match a, b with
|
|
| Moveable, Moveable -> Moveable
|
|
| Moveable_not_into_loops, Moveable
|
|
| Moveable, Moveable_not_into_loops
|
|
| Moveable_not_into_loops, Moveable_not_into_loops -> Moveable_not_into_loops
|
|
| Moveable, Fixed
|
|
| Moveable_not_into_loops, Fixed
|
|
| Fixed, Moveable_not_into_loops
|
|
| Fixed, Moveable
|
|
| Fixed, Fixed -> Fixed
|
|
|
|
let primitive_moveable (prim : Lambda.primitive)
|
|
(args : Clambda.ulambda list)
|
|
(ident_info : ident_info) =
|
|
match prim, args with
|
|
| Pfield _, [Uconst (Uconst_ref (_, _))] ->
|
|
(* CR-someday mshinwell: Actually, maybe this shouldn't be needed; these
|
|
should have been simplified to [Read_symbol_field], which doesn't yield
|
|
a Clambda let. This might be fixed when Inline_and_simplify can
|
|
turn Pfield into Read_symbol_field. *)
|
|
(* Allow field access of symbols to be moveable. (The comment in
|
|
flambda.mli on [Read_symbol_field] may be helpful to the reader.) *)
|
|
Moveable
|
|
| Pfield _, [Uvar id] when Ident.Set.mem id ident_info.closure_environment ->
|
|
(* accesses to the function environment is coeffect free: this block
|
|
is never mutated *)
|
|
Moveable
|
|
| _ ->
|
|
match Semantics_of_primitives.for_primitive prim with
|
|
| No_effects, No_coeffects -> Moveable
|
|
| No_effects, Has_coeffects
|
|
| Only_generative_effects, No_coeffects
|
|
| Only_generative_effects, Has_coeffects
|
|
| Arbitrary_effects, No_coeffects
|
|
| Arbitrary_effects, Has_coeffects -> Fixed
|
|
|
|
type moveable_for_env = Moveable | Moveable_not_into_loops
|
|
|
|
(** Called when we are entering a loop or body of a function (which may be
|
|
called multiple times). The environment is rewritten such that
|
|
identifiers previously moveable, but not into loops, are now fixed. *)
|
|
let going_into_loop env =
|
|
Ident.Map.filter_map env ~f:(fun _var ((moveable : moveable_for_env), def) ->
|
|
match moveable with
|
|
| Moveable -> Some (Moveable, def)
|
|
| Moveable_not_into_loops -> None)
|
|
|
|
(** Eliminate, through substitution, [let]-bindings of linear variables with
|
|
moveable defining expressions. *)
|
|
let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
|
|
: Clambda.ulambda * moveable =
|
|
match clam with
|
|
| Uvar id ->
|
|
begin match Ident.Map.find id env with
|
|
| Moveable, def -> def, Moveable
|
|
| Moveable_not_into_loops, def -> def, Moveable_not_into_loops
|
|
| exception Not_found ->
|
|
let moveable : moveable =
|
|
if Ident.Set.mem id ident_info.assigned then
|
|
Fixed
|
|
else
|
|
Moveable
|
|
in
|
|
clam, moveable
|
|
end
|
|
| Uconst _ ->
|
|
(* Constant closures are rewritten separately. *)
|
|
clam, Moveable
|
|
| Udirect_apply (label, args, dbg) ->
|
|
let args = un_anf_list ident_info env args in
|
|
Udirect_apply (label, args, dbg), Fixed
|
|
| Ugeneric_apply (func, args, dbg) ->
|
|
let func = un_anf ident_info env func in
|
|
let args = un_anf_list ident_info env args in
|
|
Ugeneric_apply (func, args, dbg), Fixed
|
|
| Uclosure (functions, variables_bound_by_the_closure) ->
|
|
let functions =
|
|
List.map (fun (ufunction : Clambda.ufunction) ->
|
|
{ ufunction with
|
|
body = un_anf ident_info (going_into_loop env) ufunction.body;
|
|
})
|
|
functions
|
|
in
|
|
let variables_bound_by_the_closure, moveable =
|
|
un_anf_list_and_moveable ident_info env variables_bound_by_the_closure
|
|
in
|
|
Uclosure (functions, variables_bound_by_the_closure),
|
|
both_moveable moveable Moveable_not_into_loops
|
|
| Uoffset (clam, n) ->
|
|
let clam, moveable = un_anf_and_moveable ident_info env clam in
|
|
Uoffset (clam, n), moveable
|
|
| Ulet (_let_kind, _value_kind, id, def, Uvar id') when Ident.same id id' ->
|
|
un_anf_and_moveable ident_info env def
|
|
| Ulet (let_kind, value_kind, id, def, body) ->
|
|
let def, def_moveable = un_anf_and_moveable ident_info env def in
|
|
let is_linear = Ident.Set.mem id ident_info.linear in
|
|
let is_used = Ident.Set.mem id ident_info.used in
|
|
begin match def_moveable, is_linear, is_used with
|
|
| (Moveable | Moveable_not_into_loops), _, false ->
|
|
(* A moveable expression that is never used may be eliminated. *)
|
|
un_anf_and_moveable ident_info env body
|
|
| Moveable, true, true ->
|
|
(* A moveable expression bound to a linear [Ident.t] may replace the
|
|
single occurrence of the identifier. *)
|
|
let env =
|
|
let def_moveable : moveable_for_env =
|
|
match def_moveable with
|
|
| Moveable -> Moveable
|
|
| Moveable_not_into_loops -> Moveable_not_into_loops
|
|
| Fixed -> assert false
|
|
in
|
|
Ident.Map.add id (def_moveable, def) env
|
|
in
|
|
un_anf_and_moveable ident_info env body
|
|
| Moveable_not_into_loops, true, true
|
|
(* We can't delete the [let] binding in this case because we don't
|
|
know whether the variable was substituted for its definition
|
|
(in the case of its linear use not being inside a loop) or not.
|
|
We could extend the code to cope with this case. *)
|
|
| (Moveable | Moveable_not_into_loops), false, true
|
|
(* Moveable but not used linearly. *)
|
|
| Fixed, _, _ ->
|
|
let body, body_moveable = un_anf_and_moveable ident_info env body in
|
|
Ulet (let_kind, value_kind, id, def, body),
|
|
both_moveable def_moveable body_moveable
|
|
end
|
|
| Uletrec (defs, body) ->
|
|
let defs =
|
|
List.map (fun (id, def) -> id, un_anf ident_info env def) defs
|
|
in
|
|
let body = un_anf ident_info env body in
|
|
Uletrec (defs, body), Fixed
|
|
| Uprim (prim, args, dbg) ->
|
|
let args, args_moveable = un_anf_list_and_moveable ident_info env args in
|
|
let moveable =
|
|
both_moveable args_moveable (primitive_moveable prim args ident_info)
|
|
in
|
|
Uprim (prim, args, dbg), moveable
|
|
| Uswitch (cond, sw) ->
|
|
let cond = un_anf ident_info env cond in
|
|
let sw =
|
|
{ sw with
|
|
us_actions_consts = un_anf_array ident_info env sw.us_actions_consts;
|
|
us_actions_blocks = un_anf_array ident_info env sw.us_actions_blocks;
|
|
}
|
|
in
|
|
Uswitch (cond, sw), Fixed
|
|
| Ustringswitch (cond, branches, default) ->
|
|
let cond = un_anf ident_info env cond in
|
|
let branches =
|
|
List.map (fun (s, branch) -> s, un_anf ident_info env branch)
|
|
branches
|
|
in
|
|
let default = Misc.may_map (un_anf ident_info env) default in
|
|
Ustringswitch (cond, branches, default), Fixed
|
|
| Ustaticfail (n, args) ->
|
|
let args = un_anf_list ident_info env args in
|
|
Ustaticfail (n, args), Fixed
|
|
| Ucatch (n, ids, body, handler) ->
|
|
let body = un_anf ident_info env body in
|
|
let handler = un_anf ident_info env handler in
|
|
Ucatch (n, ids, body, handler), Fixed
|
|
| Utrywith (body, id, handler) ->
|
|
let body = un_anf ident_info env body in
|
|
let handler = un_anf ident_info env handler in
|
|
Utrywith (body, id, handler), Fixed
|
|
| Uifthenelse (cond, ifso, ifnot) ->
|
|
let cond, cond_moveable = un_anf_and_moveable ident_info env cond in
|
|
let ifso, ifso_moveable = un_anf_and_moveable ident_info env ifso in
|
|
let ifnot, ifnot_moveable = un_anf_and_moveable ident_info env ifnot in
|
|
let moveable =
|
|
both_moveable cond_moveable
|
|
(both_moveable ifso_moveable ifnot_moveable)
|
|
in
|
|
Uifthenelse (cond, ifso, ifnot), moveable
|
|
| Usequence (e1, e2) ->
|
|
let e1 = un_anf ident_info env e1 in
|
|
let e2 = un_anf ident_info env e2 in
|
|
Usequence (e1, e2), Fixed
|
|
| Uwhile (cond, body) ->
|
|
let env = going_into_loop env in
|
|
let cond = un_anf ident_info env cond in
|
|
let body = un_anf ident_info env body in
|
|
Uwhile (cond, body), Fixed
|
|
| Ufor (id, low, high, direction, body) ->
|
|
let low = un_anf ident_info env low in
|
|
let high = un_anf ident_info env high in
|
|
let body = un_anf ident_info (going_into_loop env) body in
|
|
Ufor (id, low, high, direction, body), Fixed
|
|
| Uassign (id, expr) ->
|
|
let expr = un_anf ident_info env expr in
|
|
Uassign (id, expr), Fixed
|
|
| Usend (kind, e1, e2, args, dbg) ->
|
|
let e1 = un_anf ident_info env e1 in
|
|
let e2 = un_anf ident_info env e2 in
|
|
let args = un_anf_list ident_info env args in
|
|
Usend (kind, e1, e2, args, dbg), Fixed
|
|
| Uunreachable ->
|
|
Uunreachable, Fixed
|
|
|
|
and un_anf ident_info env clam : Clambda.ulambda =
|
|
let clam, _moveable = un_anf_and_moveable ident_info env clam in
|
|
clam
|
|
|
|
and un_anf_list_and_moveable ident_info env clams
|
|
: Clambda.ulambda list * moveable =
|
|
List.fold_right (fun clam (l, acc_moveable) ->
|
|
let clam, moveable = un_anf_and_moveable ident_info env clam in
|
|
clam :: l, both_moveable moveable acc_moveable)
|
|
clams ([], (Moveable : moveable))
|
|
|
|
and un_anf_list ident_info env clams : Clambda.ulambda list =
|
|
let clams, _moveable = un_anf_list_and_moveable ident_info env clams in
|
|
clams
|
|
|
|
and un_anf_array ident_info env clams : Clambda.ulambda array =
|
|
Array.map (un_anf ident_info env) clams
|
|
|
|
let apply clam ~what =
|
|
let ident_info = make_ident_info clam in
|
|
let let_bound_vars_that_can_be_moved =
|
|
let_bound_vars_that_can_be_moved ident_info clam
|
|
in
|
|
let clam =
|
|
substitute_let_moveable let_bound_vars_that_can_be_moved
|
|
Ident.Map.empty clam
|
|
in
|
|
let ident_info = make_ident_info clam in
|
|
let clam = un_anf ident_info Ident.Map.empty clam in
|
|
if !Clflags.dump_clambda then begin
|
|
Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam
|
|
end;
|
|
clam
|