2022-03-08 17:03:14 +03:00
|
|
|
(* This file is part of the Catala compiler, a specification language for tax
|
|
|
|
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
|
|
|
|
contributor: Alain Delaët-Tixeuil <alain.delaet--tixeuil@inria.fr>
|
2022-02-12 10:08:13 +03:00
|
|
|
|
2022-03-08 17:03:14 +03:00
|
|
|
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
|
|
|
use this file except in compliance with the License. You may obtain a copy of
|
|
|
|
the License at
|
2022-02-12 10:08:13 +03:00
|
|
|
|
|
|
|
http://www.apache.org/licenses/LICENSE-2.0
|
|
|
|
|
2022-03-08 17:03:14 +03:00
|
|
|
Unless required by applicable law or agreed to in writing, software
|
|
|
|
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
|
|
|
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
|
|
|
License for the specific language governing permissions and limitations under
|
2022-02-12 10:08:13 +03:00
|
|
|
the License. *)
|
|
|
|
|
2022-02-11 13:38:18 +03:00
|
|
|
open Utils
|
|
|
|
module D = Ast
|
|
|
|
|
|
|
|
type scope_lets =
|
|
|
|
| Result of D.expr Pos.marked
|
|
|
|
| ScopeLet of {
|
|
|
|
scope_let_kind : D.scope_let_kind;
|
|
|
|
scope_let_typ : D.typ Pos.marked;
|
|
|
|
scope_let_expr : D.expr Pos.marked;
|
|
|
|
scope_let_next : (D.expr, scope_lets) Bindlib.binder;
|
|
|
|
scope_let_pos : Pos.t;
|
|
|
|
}
|
|
|
|
|
|
|
|
type scope_body = {
|
|
|
|
scope_body_input_struct : D.StructName.t;
|
|
|
|
scope_body_output_struct : D.StructName.t;
|
|
|
|
scope_body_result : (D.expr, scope_lets) Bindlib.binder;
|
|
|
|
}
|
|
|
|
|
|
|
|
type scopes =
|
|
|
|
| Nil
|
|
|
|
| ScopeDef of {
|
|
|
|
scope_name : D.ScopeName.t;
|
|
|
|
scope_body : scope_body;
|
|
|
|
scope_next : (D.expr, scopes) Bindlib.binder;
|
|
|
|
}
|
|
|
|
|
2022-02-18 17:49:23 +03:00
|
|
|
let union : unit D.VarMap.t -> unit D.VarMap.t -> unit D.VarMap.t =
|
|
|
|
D.VarMap.union (fun _ _ _ -> Some ())
|
2022-02-11 13:38:18 +03:00
|
|
|
|
2022-02-21 13:51:01 +03:00
|
|
|
let rec free_vars_set_scope_lets (scope_lets : scope_lets) : unit D.VarMap.t =
|
2022-02-11 13:38:18 +03:00
|
|
|
match scope_lets with
|
2022-02-21 13:51:01 +03:00
|
|
|
| Result e -> D.free_vars_set e
|
2022-02-11 13:38:18 +03:00
|
|
|
| ScopeLet { scope_let_expr = e; scope_let_next = next; _ } ->
|
|
|
|
let v, body = Bindlib.unbind next in
|
2022-03-08 17:03:14 +03:00
|
|
|
union (D.free_vars_set e)
|
|
|
|
(D.VarMap.remove v (free_vars_set_scope_lets body))
|
2022-02-11 13:38:18 +03:00
|
|
|
|
2022-02-21 13:51:01 +03:00
|
|
|
let free_vars_set_scope_body (scope_body : scope_body) : unit D.VarMap.t =
|
2022-02-18 17:31:52 +03:00
|
|
|
let { scope_body_result = binder; _ } = scope_body in
|
2022-02-11 13:38:18 +03:00
|
|
|
let v, body = Bindlib.unbind binder in
|
2022-02-21 13:51:01 +03:00
|
|
|
D.VarMap.remove v (free_vars_set_scope_lets body)
|
2022-02-11 13:38:18 +03:00
|
|
|
|
2022-02-21 13:51:01 +03:00
|
|
|
let rec free_vars_set_scopes (scopes : scopes) : unit D.VarMap.t =
|
2022-02-11 13:38:18 +03:00
|
|
|
match scopes with
|
|
|
|
| Nil -> D.VarMap.empty
|
|
|
|
| ScopeDef { scope_body = body; scope_next = next; _ } ->
|
|
|
|
let v, next = Bindlib.unbind next in
|
|
|
|
|
2022-03-08 17:03:14 +03:00
|
|
|
union
|
|
|
|
(D.VarMap.remove v (free_vars_set_scopes next))
|
|
|
|
(free_vars_set_scope_body body)
|
2022-02-11 13:38:18 +03:00
|
|
|
|
2022-02-21 13:51:01 +03:00
|
|
|
let free_vars_list_scope_lets (scope_lets : scope_lets) : D.Var.t list =
|
|
|
|
free_vars_set_scope_lets scope_lets |> D.VarMap.bindings |> List.map fst
|
2022-02-11 13:38:18 +03:00
|
|
|
|
2022-02-21 13:51:01 +03:00
|
|
|
let free_vars_list_scope_body (scope_body : scope_body) : D.Var.t list =
|
|
|
|
free_vars_set_scope_body scope_body |> D.VarMap.bindings |> List.map fst
|
2022-02-11 13:38:18 +03:00
|
|
|
|
2022-02-21 13:51:01 +03:00
|
|
|
let free_vars_list_scopes (scopes : scopes) : D.Var.t list =
|
|
|
|
free_vars_set_scopes scopes |> D.VarMap.bindings |> List.map fst
|
2022-02-11 13:38:18 +03:00
|
|
|
|
2022-02-12 10:08:13 +03:00
|
|
|
(** Actual transformation for scopes. *)
|
2022-02-11 13:38:18 +03:00
|
|
|
let bind_scope_lets (acc : scope_lets Bindlib.box) (scope_let : D.scope_let) :
|
|
|
|
scope_lets Bindlib.box =
|
|
|
|
let pos = snd scope_let.D.scope_let_var in
|
|
|
|
|
2022-03-08 17:03:14 +03:00
|
|
|
(* Cli.debug_print @@ Format.asprintf "binding let %a. Variable occurs = %b"
|
|
|
|
Print.format_var (fst scope_let.D.scope_let_var) (Bindlib.occur (fst
|
|
|
|
scope_let.D.scope_let_var) acc); *)
|
2022-02-11 13:38:18 +03:00
|
|
|
let binder = Bindlib.bind_var (fst scope_let.D.scope_let_var) acc in
|
|
|
|
Bindlib.box_apply2
|
|
|
|
(fun expr binder ->
|
2022-03-08 17:03:14 +03:00
|
|
|
(* Cli.debug_print @@ Format.asprintf "free variables in expression: %a"
|
|
|
|
(Format.pp_print_list Print.format_var) (D.free_vars_list expr); *)
|
2022-02-11 13:38:18 +03:00
|
|
|
ScopeLet
|
|
|
|
{
|
|
|
|
scope_let_kind = scope_let.D.scope_let_kind;
|
|
|
|
scope_let_typ = scope_let.D.scope_let_typ;
|
|
|
|
scope_let_expr = expr;
|
|
|
|
scope_let_next = binder;
|
|
|
|
scope_let_pos = pos;
|
|
|
|
})
|
|
|
|
scope_let.D.scope_let_expr binder
|
|
|
|
|
|
|
|
let bind_scope_body (body : D.scope_body) : scope_body Bindlib.box =
|
|
|
|
(* it is a fold_right and not a fold_left. *)
|
|
|
|
let body_result =
|
|
|
|
ListLabels.fold_right body.D.scope_body_lets
|
|
|
|
~init:(Bindlib.box_apply (fun e -> Result e) body.D.scope_body_result)
|
|
|
|
~f:(Fun.flip bind_scope_lets)
|
|
|
|
in
|
|
|
|
|
2022-03-08 17:03:14 +03:00
|
|
|
(* Cli.debug_print @@ Format.asprintf "binding arg %a" Print.format_var
|
|
|
|
body.D.scope_body_arg; *)
|
2022-02-11 13:38:18 +03:00
|
|
|
let scope_body_result = Bindlib.bind_var body.D.scope_body_arg body_result in
|
|
|
|
|
2022-03-08 17:03:14 +03:00
|
|
|
(* Cli.debug_print @@ Format.asprintf "isfinal term is closed: %b"
|
|
|
|
(Bindlib.is_closed scope_body_result); *)
|
2022-02-11 13:38:18 +03:00
|
|
|
Bindlib.box_apply
|
|
|
|
(fun scope_body_result ->
|
2022-03-08 17:03:14 +03:00
|
|
|
(* Cli.debug_print @@ Format.asprintf "rank of the final term: %i"
|
|
|
|
(Bindlib.binder_rank scope_body_result); *)
|
2022-02-11 13:38:18 +03:00
|
|
|
{
|
|
|
|
scope_body_output_struct = body.D.scope_body_output_struct;
|
|
|
|
scope_body_input_struct = body.D.scope_body_input_struct;
|
|
|
|
scope_body_result;
|
|
|
|
})
|
|
|
|
scope_body_result
|
|
|
|
|
|
|
|
let bind_scope
|
2022-03-08 17:03:14 +03:00
|
|
|
((scope_name, scope_var, scope_body) :
|
|
|
|
D.ScopeName.t * D.expr Bindlib.var * D.scope_body)
|
2022-02-11 13:38:18 +03:00
|
|
|
(acc : scopes Bindlib.box) : scopes Bindlib.box =
|
|
|
|
Bindlib.box_apply2
|
2022-03-08 17:03:14 +03:00
|
|
|
(fun scope_body scope_next ->
|
|
|
|
ScopeDef { scope_name; scope_body; scope_next })
|
|
|
|
(bind_scope_body scope_body)
|
|
|
|
(Bindlib.bind_var scope_var acc)
|
2022-02-11 13:38:18 +03:00
|
|
|
|
2022-03-08 17:03:14 +03:00
|
|
|
let bind_scopes
|
|
|
|
(scopes : (D.ScopeName.t * D.expr Bindlib.var * D.scope_body) list) :
|
2022-02-11 13:38:18 +03:00
|
|
|
scopes Bindlib.box =
|
2022-03-08 17:03:14 +03:00
|
|
|
let result =
|
|
|
|
ListLabels.fold_right scopes ~init:(Bindlib.box Nil) ~f:bind_scope
|
|
|
|
in
|
|
|
|
(* Cli.debug_print @@ Format.asprintf "free variable in the program : [%a]"
|
|
|
|
(Format.pp_print_list Print.format_var) (free_vars_list_scopes
|
|
|
|
(Bindlib.unbox result)); *)
|
2022-02-11 13:38:18 +03:00
|
|
|
result
|