2022-01-28 11:28:02 +03:00
open Utils
module D = Dcalc . Ast
module A = Ast
2022-02-03 19:16:45 +03:00
(* * hoisting *)
2022-02-04 11:27:10 +03:00
(* * The main idea around this pass is to compile Dcalc to Lcalc without using [raise EmptyError] nor
[ try _ with EmptyError -> _ ] . To do so , we use the same technique as in rust or erlang to handle
this kind of exceptions . Each [ raise EmptyError ] will be translated as [ None ] and each
[ try e1 with EmtpyError -> e2 ] as [ match e1 with | None -> e2 | Some x -> x ] .
2022-02-01 19:49:00 +03:00
2022-02-04 11:27:10 +03:00
When doing this naively , this requires to add matches and Some constructor everywhere . We apply
here an other technique where we generate what we call ` cuts ` . Cuts are expression whom could
minimally [ raise EmptyError ] . For instance
[ let x = < e1 , e2 , .. . , en | e_just : - e_cons > * 3 in x + 1 ] , the sub - expression
[< e1 , e2 , .. . , en | e_just : - e_cons >] can produce an empty error . So we make a cut with a new
variable [ y ] linked to the Dcalc expression [< e1 , e2 , .. . , en | e_just : - e_cons >] , and we return
as the translated expression [ let x = y * 3 in x + 1 ] .
2022-02-02 14:10:47 +03:00
2022-02-04 11:27:10 +03:00
The compilation of expressions is found in the functions [ translate_and_cut ctx e ] and
[ translate_expr ctx e ] . Every option - generating expresion when calling [ translate_and_cut ] will
be cutted and later handled by the [ translate_expr ] function . Every other cases is found in the
translate_and_cut function . * )
2022-02-01 19:49:00 +03:00
2022-02-02 14:10:47 +03:00
type cuts = D . expr Pos . marked A . VarMap . t
2022-02-04 11:27:10 +03:00
(* * cuts *)
2022-02-02 14:10:47 +03:00
2022-02-04 11:27:10 +03:00
type info = { expr : A . expr Pos . marked Bindlib . box ; var : A . expr Bindlib . var ; is_pure : bool }
(* * information about the Dcalc variable : what is the corresponding LCalc variable; an expression
2022-02-04 16:32:12 +03:00
build correctly using Bindlib , and a boolean ` is_pure ` indicating whenever the variable can be an EmptyError and hence should be matched ( false ) or if it never can be EmptyError ( true ) . * )
2022-01-28 11:28:02 +03:00
2022-02-04 11:27:10 +03:00
type ctx = info D . VarMap . t
2022-01-28 11:28:02 +03:00
(* * information context about variables in the current scope *)
2022-02-04 11:27:10 +03:00
let pp_info ( fmt : Format . formatter ) ( info : info ) =
2022-02-04 16:32:12 +03:00
Format . fprintf fmt " {var: %a; is_pure: %b} " Print . format_var info . var info . is_pure
2022-02-03 13:50:18 +03:00
2022-02-04 11:27:10 +03:00
let pp_binding ( fmt : Format . formatter ) ( ( v , info ) : D . Var . t * info ) =
2022-02-04 16:32:12 +03:00
Format . fprintf fmt " %a:%a " Dcalc . Print . format_var v pp_info info
2022-02-03 13:50:18 +03:00
2022-02-04 11:27:10 +03:00
let pp_ctx ( fmt : Format . formatter ) ( ctx : ctx ) =
let pp_bindings =
Format . pp_print_list ~ pp_sep : ( fun fmt () -> Format . pp_print_string fmt " ; " ) pp_binding
in
2022-02-03 19:16:45 +03:00
Format . fprintf fmt " @[<2>[%a]@] " pp_bindings ( D . VarMap . bindings ctx )
2022-02-03 13:50:18 +03:00
2022-02-04 16:32:12 +03:00
(* * [find ~info n ctx] is a warpper to ocaml's Map.find that handle errors in a slightly better way. *)
let find ? ( info : string = " none " ) ( n : D . Var . t ) ( ctx : ctx ) : info =
2022-02-04 11:27:10 +03:00
let _ =
2022-02-04 16:32:12 +03:00
Format . asprintf " Searching for variable %a inside context %a "
Dcalc . Print . format_var n pp_ctx ctx
2022-02-03 13:50:18 +03:00
| > Cli . debug_print
in
2022-02-04 11:27:10 +03:00
try D . VarMap . find n ctx
2022-02-03 13:50:18 +03:00
with Not_found ->
2022-02-04 11:27:10 +03:00
Errors . raise_spanned_error
2022-02-04 16:32:12 +03:00
( Format . asprintf
" Internal Error: Variable %a was not found in the current environment. Additional \
2022-02-04 11:27:10 +03:00
informations : % s . "
2022-02-04 16:32:12 +03:00
Dcalc . Print . format_var n info )
2022-02-04 11:27:10 +03:00
Pos . no_pos
2022-02-02 19:33:36 +03:00
2022-02-04 16:32:12 +03:00
let add_var ( pos : Pos . t ) ( var : D . Var . t ) ( is_pure : bool ) ( ctx : ctx ) : ctx =
2022-02-02 19:33:36 +03:00
let new_var = A . Var . make ( Bindlib . name_of var , pos ) in
let expr = A . make_var ( new_var , pos ) in
2022-02-03 13:50:18 +03:00
2022-02-04 16:32:12 +03:00
Cli . debug_print @@ Format . asprintf " D.%a |-> A.%a "
Dcalc . Print . format_var var
Print . format_var new_var ;
2022-02-04 11:27:10 +03:00
D . VarMap . update var ( fun _ -> Some { expr ; var = new_var ; is_pure } ) ctx
2022-02-03 13:50:18 +03:00
2022-02-04 11:27:10 +03:00
(* D.VarMap.add var { expr; var = new_var; is_pure } ctx *)
2022-02-02 19:33:36 +03:00
2022-02-04 11:27:10 +03:00
let translate_lit ( l : D . lit ) ( pos : Pos . t ) : A . lit =
2022-01-28 13:07:29 +03:00
match l with
2022-02-04 11:27:10 +03:00
| D . LBool l -> A . LBool l
| D . LInt i -> A . LInt i
| D . LRat r -> A . LRat r
| D . LMoney m -> A . LMoney m
2022-01-28 13:07:29 +03:00
| D . LUnit -> A . LUnit
2022-02-04 11:27:10 +03:00
| D . LDate d -> A . LDate d
| D . LDuration d -> A . LDuration d
| D . LEmptyError ->
Errors . raise_spanned_error
" Internal Error: An empty error was found in a place that shouldn't be possible. " pos
(* * [c = disjoint_union_maps cs] Compute the disjoint union of multiple maps. Raises an internal
error if there is two identicals keys in differnts parts . * )
let disjoint_union_maps ( pos : Pos . t ) ( cs : ' a A . VarMap . t list ) : ' a A . VarMap . t =
let disjoint_union =
A . VarMap . union ( fun _ _ _ ->
Errors . raise_spanned_error
" Internal Error: Two supposed to be disjoints maps have one shared key. " pos )
in
2022-01-28 13:07:29 +03:00
List . fold_left disjoint_union A . VarMap . empty cs
2022-02-04 11:27:10 +03:00
(* * [e' = translate_and_cut ctx e ] Translate the Dcalc expression e into an expression in Lcalc,
given we translate each cuts correctly . It ensures the equivalence between the execution of e
and the execution of e' are equivalent in an environement where each variable v , where ( v , e_v )
is in cuts , has the non - empty value in e_v . * )
let rec translate_and_cut ( ctx : ctx ) ( e : D . expr Pos . marked ) : A . expr Pos . marked Bindlib . box * cuts
=
2022-01-28 13:07:29 +03:00
let pos = Pos . get_position e in
2022-01-28 11:28:02 +03:00
match Pos . unmark e with
2022-02-02 19:33:36 +03:00
(* empty-producing/using terms. We cut those. ( D.EVar in some cases, EApp ( D.EVar _, [ELit LUnit] ) , EDefault _, ELit LEmptyDefault ) I'm unsure about assert. *)
2022-01-28 11:28:02 +03:00
| D . EVar v ->
2022-02-04 16:32:12 +03:00
(* todo: for now, every unpure ( such that [is_pure] is [false] in the current context ) is thunked, hence matched in the next case. This assumption can change in the future, and this case is here for this reason. *)
2022-02-04 11:27:10 +03:00
let v , pos_v = v in
if not ( find ~ info : " search for a variable " v ctx ) . is_pure then begin
let v' = A . Var . make ( Bindlib . name_of v , pos_v ) in
Cli . debug_print
2022-02-04 16:32:12 +03:00
@@ Format . asprintf " Found an unpure variable %a, created a variable %a to replace it " Dcalc . Print . format_var
v Print . format_var v' ;
2022-02-04 11:27:10 +03:00
( A . make_var ( v' , pos ) , A . VarMap . singleton v' e )
end
else ( ( find ~ info : " should never happend " v ctx ) . expr , A . VarMap . empty )
2022-02-02 19:33:36 +03:00
| D . EApp ( ( D . EVar ( v , pos_v ) , p ) , [ ( D . ELit D . LUnit , _ ) ] ) ->
2022-02-04 11:27:10 +03:00
if not ( find ~ info : " search for a variable " v ctx ) . is_pure then begin
let v' = A . Var . make ( Bindlib . name_of v , pos_v ) in
Cli . debug_print
2022-02-04 16:32:12 +03:00
@@ Format . asprintf " Found an unpure variable %a, created a variable %a to replace it " Dcalc . Print . format_var
v Print . format_var v' ;
2022-02-04 11:27:10 +03:00
( A . make_var ( v' , pos ) , A . VarMap . singleton v' ( D . EVar ( v , pos_v ) , p ) )
end
else
Errors . raise_spanned_error
" Internal error: an pure variable was found in an unpure environment. " pos
2022-01-28 13:07:29 +03:00
| D . EDefault ( _ exceptions , _ just , _ cons ) ->
2022-02-04 11:27:10 +03:00
let v' = A . Var . make ( " default_term " , pos ) in
( A . make_var ( v' , pos ) , A . VarMap . singleton v' e )
2022-01-28 13:07:29 +03:00
| D . ELit D . LEmptyError ->
2022-02-04 11:27:10 +03:00
let v' = A . Var . make ( " empty_litteral " , pos ) in
( A . make_var ( v' , pos ) , A . VarMap . singleton v' e )
2022-02-01 19:49:00 +03:00
| D . EAssert _ ->
2022-02-04 11:27:10 +03:00
(* as discuted, if the value in an assertion is empty, an error should the raised. This beavior is different from the ICFP paper. *)
let v' = A . Var . make ( " assertion_value " , pos ) in
( A . make_var ( v' , pos ) , A . VarMap . singleton v' e )
2022-02-02 19:33:36 +03:00
(* This one is a very special case. It transform an unpure expression environement to a pure expression. *)
| ErrorOnEmpty arg ->
2022-02-04 11:27:10 +03:00
(* [
match arg with
| None -> raise NoValueProvided
| Some v -> { { v } }
] * )
let silent_var = A . Var . make ( " _ " , pos ) in
let x = A . Var . make ( " non_empty_argument " , pos ) in
let arg' = translate_expr ctx arg in
2022-02-04 16:32:12 +03:00
( A . make_matchopt_with_abs_arms arg'
2022-02-04 11:27:10 +03:00
( A . make_abs [| silent_var |]
( Bindlib . box ( A . ERaise A . NoValueProvided , pos ) )
pos [ ( D . TAny , pos ) ] pos )
( A . make_abs [| x |] ( A . make_var ( x , pos ) ) pos [ ( D . TAny , pos ) ] pos ) ,
A . VarMap . empty )
2022-01-28 13:07:29 +03:00
(* pure terms *)
2022-02-04 11:27:10 +03:00
| D . ELit l -> ( Bindlib . box ( A . ELit ( translate_lit l pos ) , pos ) , A . VarMap . empty )
2022-01-28 11:28:02 +03:00
| D . EIfThenElse ( e1 , e2 , e3 ) ->
2022-02-04 11:27:10 +03:00
let e1' , c1 = translate_and_cut ctx e1 in
let e2' , c2 = translate_and_cut ctx e2 in
let e3' , c3 = translate_and_cut ctx e3 in
2022-01-28 13:07:29 +03:00
2022-02-04 11:27:10 +03:00
let e' =
Bindlib . box_apply3 ( fun e1' e2' e3' -> ( A . EIfThenElse ( e1' , e2' , e3' ) , pos ) ) e1' e2' e3'
in
(* (* equivalent code : *)
let e' =
let + e1' = e1' and + e2' = e2' and + e3' = e3' in
( A . EIfThenElse ( e1' , e2' , e3' ) , pos )
in
* )
( e' , disjoint_union_maps pos [ c1 ; c2 ; c3 ] )
2022-02-03 20:56:37 +03:00
| D . EAbs ( ( binder , pos_binder ) , ts ) ->
2022-02-04 11:27:10 +03:00
let vars , body = Bindlib . unmbind binder in
let ctx , lc_vars =
ArrayLabels . fold_right vars ~ init : ( ctx , [] ) ~ f : ( fun var ( ctx , lc_vars ) ->
(* we suppose the invariant that when applying a function, its arguments cannot be of the type "option".
The code should behave correctly in the without this assumption if we put here an is_pure = false , but the types are more compilcated . ( unimplemented for now ) * )
let ctx = add_var pos var true ctx in
let lc_var = ( find var ctx ) . var in
( ctx , lc_var :: lc_vars ) )
in
let lc_vars = Array . of_list lc_vars in
(* here we take the guess that if we cannot build the closure because one of the variable is empty, then we cannot build the function. *)
let new_body , cuts = translate_and_cut ctx body in
let new_binder = Bindlib . bind_mvar lc_vars new_body in
( Bindlib . box_apply ( fun new_binder -> ( A . EAbs ( ( new_binder , pos_binder ) , ts ) , pos ) ) new_binder ,
cuts )
2022-02-01 19:49:00 +03:00
| EApp ( e1 , args ) ->
(* general case is simple *)
let e1' , c1 = translate_and_cut ctx e1 in
2022-02-04 11:27:10 +03:00
let args' , c_args = args | > List . map ( translate_and_cut ctx ) | > List . split in
2022-02-01 19:49:00 +03:00
2022-02-04 11:27:10 +03:00
let cuts = disjoint_union_maps pos ( c1 :: c_args ) in
let e' =
Bindlib . box_apply2
( fun e1' args' -> ( A . EApp ( e1' , args' ) , pos ) )
e1' ( Bindlib . box_list args' )
2022-02-01 19:49:00 +03:00
in
( e' , cuts )
| ETuple ( args , s ) ->
2022-02-04 11:27:10 +03:00
let args' , c_args = args | > List . map ( translate_and_cut ctx ) | > List . split in
2022-02-01 19:49:00 +03:00
2022-02-04 11:27:10 +03:00
let cuts = disjoint_union_maps pos c_args in
( Bindlib . box_apply ( fun args' -> ( A . ETuple ( args' , s ) , pos ) ) ( Bindlib . box_list args' ) , cuts )
2022-02-01 19:49:00 +03:00
| ETupleAccess ( e1 , i , s , ts ) ->
2022-02-04 11:27:10 +03:00
let e1' , cuts = translate_and_cut ctx e1 in
let e1' = Bindlib . box_apply ( fun e1' -> ( A . ETupleAccess ( e1' , i , s , ts ) , pos ) ) e1' in
( e1' , cuts )
2022-02-01 19:49:00 +03:00
| EInj ( e1 , i , en , ts ) ->
2022-02-04 11:27:10 +03:00
let e1' , cuts = translate_and_cut ctx e1 in
let e1' = Bindlib . box_apply ( fun e1' -> ( A . EInj ( e1' , i , en , ts ) , pos ) ) e1' in
( e1' , cuts )
2022-02-01 19:49:00 +03:00
| EMatch ( e1 , cases , en ) ->
2022-02-04 11:27:10 +03:00
let e1' , c1 = translate_and_cut ctx e1 in
let cases' , c_cases = cases | > List . map ( translate_and_cut ctx ) | > List . split in
2022-02-01 19:49:00 +03:00
2022-02-04 11:27:10 +03:00
let cuts = disjoint_union_maps pos ( c1 :: c_cases ) in
let e' =
Bindlib . box_apply2
( fun e1' cases' -> ( A . EMatch ( e1' , cases' , en ) , pos ) )
e1' ( Bindlib . box_list cases' )
2022-02-01 19:49:00 +03:00
in
( e' , cuts )
| EArray es ->
2022-02-04 11:27:10 +03:00
let es' , cuts = es | > List . map ( translate_and_cut ctx ) | > List . split in
2022-01-28 13:07:29 +03:00
2022-02-04 11:27:10 +03:00
( Bindlib . box_apply ( fun es' -> ( A . EArray es' , pos ) ) ( Bindlib . box_list es' ) ,
disjoint_union_maps pos cuts )
2022-02-01 19:49:00 +03:00
| EOp op -> ( Bindlib . box ( A . EOp op , pos ) , A . VarMap . empty )
2022-01-28 11:28:02 +03:00
2022-02-04 11:27:10 +03:00
and translate_expr ? ( append_esome = true ) ( ctx : ctx ) ( e : D . expr Pos . marked ) :
A . expr Pos . marked Bindlib . box =
let e' , cs = translate_and_cut ctx e in
let cs = A . VarMap . bindings cs in
2022-02-03 19:16:45 +03:00
2022-02-04 11:27:10 +03:00
let _ pos = Pos . get_position e in
2022-01-28 13:07:29 +03:00
2022-02-04 11:27:10 +03:00
(* build the cuts *)
Cli . debug_print
2022-02-04 16:32:12 +03:00
@@ Format . asprintf " cut for the expression: [%a] " ( Format . pp_print_list Print . format_var ) ( List . map fst cs ) ;
2022-02-03 19:16:45 +03:00
2022-02-04 11:27:10 +03:00
ListLabels . fold_left cs
~ init : ( if append_esome then A . make_some e' else e' )
~ f : ( fun acc ( v , ( c , pos_c ) ) ->
2022-02-04 16:32:12 +03:00
Cli . debug_print @@ Format . asprintf " cut using A.%a " Print . format_var v ;
2022-02-03 19:16:45 +03:00
2022-02-04 11:27:10 +03:00
let c' : A . expr Pos . marked Bindlib . box =
match c with
2022-01-28 13:07:29 +03:00
(* Here we have to handle only the cases appearing in cuts, as defined the [translate_and_cut] function. *)
2022-02-02 19:33:36 +03:00
| D . EVar v -> ( find ~ info : " should never happend " ( Pos . unmark v ) ctx ) . expr
2022-01-28 13:07:29 +03:00
| D . EDefault ( excep , just , cons ) ->
2022-02-04 11:27:10 +03:00
let excep' = List . map ( translate_expr ctx ) excep in
let just' = translate_expr ctx just in
let cons' = translate_expr ctx cons in
(* calls handle_option. *)
A . make_app
( A . make_var ( A . handle_default_opt , pos_c ) )
[
Bindlib . box_apply ( fun excep' -> ( A . EArray excep' , pos_c ) ) ( Bindlib . box_list excep' ) ;
just' ;
cons' ;
]
pos_c
| D . ELit D . LEmptyError -> A . make_none pos_c
2022-02-01 19:49:00 +03:00
| D . EAssert arg ->
2022-02-04 11:27:10 +03:00
let arg' = translate_expr ctx arg in
(* [
match arg with
| None -> raise NoValueProvided
| Some v -> assert { { v } }
] * )
let silent_var = A . Var . make ( " _ " , pos_c ) in
let x = A . Var . make ( " assertion_argument " , pos_c ) in
2022-02-04 16:32:12 +03:00
A . make_matchopt_with_abs_arms arg'
2022-02-04 11:27:10 +03:00
( A . make_abs [| silent_var |]
( Bindlib . box ( A . ERaise A . NoValueProvided , pos_c ) )
pos_c [ ( D . TAny , pos_c ) ] pos_c )
( A . make_abs [| x |]
( Bindlib . box_apply ( fun arg -> ( A . EAssert arg , pos_c ) ) ( A . make_var ( x , pos_c ) ) )
pos_c [ ( D . TAny , pos_c ) ] pos_c )
| _ ->
Errors . raise_spanned_error
" Internal Error: An term was found in a position where it should not be " pos_c
in
2022-02-02 19:33:36 +03:00
2022-02-04 11:27:10 +03:00
(* [
match { { c' } } with
| None -> None
| Some { { v } } -> { { acc } }
end
] * )
2022-02-04 16:32:12 +03:00
Cli . debug_print @@ Format . asprintf " build matchopt using %a " Print . format_var v ;
2022-02-04 11:27:10 +03:00
A . make_matchopt pos_c v ( D . TAny , pos_c ) c' ( A . make_none pos_c ) acc )
2022-02-03 20:30:58 +03:00
2022-02-03 20:27:55 +03:00
type scope_lets =
2022-02-04 11:27:10 +03:00
| 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 ;
2022-02-03 20:27:55 +03:00
}
2022-02-04 11:24:51 +03:00
let union = D . VarMap . union ( fun _ _ _ -> Some () )
2022-02-04 11:27:10 +03:00
2022-02-04 11:24:51 +03:00
let rec fv_scope_lets scope_lets =
match scope_lets with
| Result e -> D . fv e
2022-02-04 11:27:10 +03:00
| ScopeLet { scope_let_expr = e ; scope_let_next = next ; _ } ->
let v , body = Bindlib . unbind next in
union ( D . fv e ) ( D . VarMap . remove v ( fv_scope_lets body ) )
2022-02-04 11:24:51 +03:00
2022-02-03 20:48:17 +03:00
type scope_body = {
2022-02-04 11:27:10 +03:00
scope_body_input_struct : D . StructName . t ;
scope_body_output_struct : D . StructName . t ;
scope_body_result : ( D . expr , scope_lets ) Bindlib . binder ;
2022-02-03 20:48:17 +03:00
}
2022-02-04 11:24:51 +03:00
2022-02-04 11:27:10 +03:00
let fv_scope_body { scope_body_result = binder ; _ } =
2022-02-04 11:24:51 +03:00
let v , body = Bindlib . unbind binder in
D . VarMap . remove v ( fv_scope_lets body )
2022-02-04 11:27:10 +03:00
let free_vars_scope_body scope_body = fv_scope_body scope_body | > D . VarMap . bindings | > List . map fst
2022-02-03 20:27:55 +03:00
2022-02-04 11:27:10 +03:00
let translate_and_bind_lets ( acc : scope_lets Bindlib . box ) ( scope_let : D . scope_let ) :
scope_lets Bindlib . box =
2022-02-03 20:48:17 +03:00
let pos = snd scope_let . D . scope_let_var in
2022-02-04 11:24:51 +03:00
2022-02-04 11:27:10 +03:00
Cli . debug_print
2022-02-04 16:32:12 +03:00
@@ Format . asprintf " binding let %a. Variable occurs = %b " Dcalc . Print . format_var ( fst scope_let . D . scope_let_var )
2022-02-04 11:27:10 +03:00
( Bindlib . occur ( fst scope_let . D . scope_let_var ) acc ) ;
2022-02-04 11:24:51 +03:00
let binder = Bindlib . bind_var ( fst scope_let . D . scope_let_var ) acc in
2022-02-04 11:27:10 +03:00
Bindlib . box_apply2
( fun expr binder ->
Cli . debug_print
2022-02-04 16:32:12 +03:00
@@ Format . asprintf " free variables in expression: %a " ( Format . pp_print_list Dcalc . Print . format_var )
2022-02-04 11:27:10 +03:00
( D . free_vars expr ) ;
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 translate_and_bind ( body : D . scope_body ) : scope_body Bindlib . box =
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 translate_and_bind_lets )
2022-02-03 20:27:55 +03:00
in
2022-02-04 16:32:12 +03:00
Cli . debug_print @@ Format . asprintf " binding arg %a " Dcalc . Print . format_var body . D . scope_body_arg ;
2022-02-03 20:27:55 +03:00
let scope_body_result = Bindlib . bind_var body . D . scope_body_arg body_result in
2022-02-04 11:27:10 +03:00
Cli . debug_print
@@ Format . asprintf " isfinal term is closed: %b " ( Bindlib . is_closed scope_body_result ) ;
Bindlib . box_apply
( fun scope_body_result ->
Cli . debug_print
@@ Format . asprintf " rank of the final term: %i " ( Bindlib . binder_rank scope_body_result ) ;
{
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
2022-02-04 11:24:51 +03:00
2022-02-04 11:27:10 +03:00
let rec translate_scope_let ( ctx : ctx ) ( lets : scope_lets ) =
2022-02-03 20:48:17 +03:00
match lets with
2022-02-04 11:27:10 +03:00
| Result e -> translate_expr ~ append_esome : false ctx e
| ScopeLet
{
scope_let_kind = kind ;
scope_let_typ = typ ;
scope_let_expr = expr ;
scope_let_next = next ;
scope_let_pos = pos ;
} ->
let var_is_pure =
match kind with
| DestructuringInputStruct -> false
| ScopeVarDefinition | SubScopeVarDefinition | CallingSubScope
| DestructuringSubScopeResults | Assertion ->
true
in
let var , next = Bindlib . unbind next in
2022-02-04 16:32:12 +03:00
Cli . debug_print @@ Format . asprintf " unbinding %a " Dcalc . Print . format_var var ;
2022-02-04 11:27:10 +03:00
let ctx' = add_var pos var var_is_pure ctx in
let new_var = ( find ~ info : " variable that was just created " var ctx' ) . var in
A . make_let_in new_var typ
( translate_expr ctx ~ append_esome : false expr )
( translate_scope_let ctx' next )
let translate_scope_body ( scope_pos : Pos . t ) ( _ decl_ctx : D . decl_ctx ) ( ctx : ctx )
( body : scope_body ) : A . expr Pos . marked Bindlib . box =
2022-02-02 14:01:05 +03:00
match body with
2022-02-04 11:27:10 +03:00
| {
scope_body_result = result ;
scope_body_input_struct = _ input_struct ;
scope_body_output_struct = _ output_struct ;
2022-02-02 14:01:05 +03:00
} ->
2022-02-04 11:27:10 +03:00
let v , lets = Bindlib . unbind result in
2022-02-02 19:33:36 +03:00
2022-02-04 11:27:10 +03:00
let ctx' = add_var scope_pos v true ctx in
2022-02-02 19:33:36 +03:00
2022-02-04 11:27:10 +03:00
translate_scope_let ctx' lets
2022-02-02 14:01:05 +03:00
2022-02-04 11:27:10 +03:00
let translate_program ( prgm : D . program ) : A . program =
2022-02-02 14:01:05 +03:00
(* modify *)
2022-02-04 11:27:10 +03:00
let decl_ctx =
{
D . ctx_enums = prgm . decl_ctx . ctx_enums | > D . EnumMap . add A . option_enum A . option_enum_config ;
D . ctx_structs = prgm . decl_ctx . ctx_structs ;
}
2022-02-02 19:33:36 +03:00
in
2022-02-02 14:01:05 +03:00
2022-02-04 11:27:10 +03:00
let scopes =
prgm . scopes
2022-02-02 14:01:05 +03:00
| > ListLabels . fold_left ~ init : ( [] , D . VarMap . empty )
2022-02-04 11:27:10 +03:00
~ f : ( fun ( ( acc , ctx ) : _ * info D . VarMap . t ) ( scope_name , n , scope_body ) ->
let scope_body = Bindlib . unbox ( translate_and_bind scope_body ) in
2022-02-04 11:24:51 +03:00
2022-02-04 11:27:10 +03:00
Cli . debug_print
2022-02-04 16:32:12 +03:00
@@ Format . asprintf " global free variable : %a " ( Format . pp_print_list Dcalc . Print . format_var )
2022-02-04 11:27:10 +03:00
( free_vars_scope_body scope_body ) ;
let new_ctx = add_var Pos . no_pos n true ctx in
2022-02-02 19:33:36 +03:00
2022-02-04 11:27:10 +03:00
let new_n = find ~ info : " variable that was just created " n new_ctx in
2022-02-02 14:01:05 +03:00
2022-02-04 11:27:10 +03:00
let scope_pos = Pos . get_position ( D . ScopeName . get_info scope_name ) in
2022-02-02 14:01:05 +03:00
2022-02-04 11:27:10 +03:00
let new_acc =
( new_n , Bindlib . unbox ( translate_scope_body scope_pos decl_ctx ctx scope_body ) ) :: acc
in
2022-02-02 14:01:05 +03:00
2022-02-04 11:27:10 +03:00
( new_acc , new_ctx ) )
| > fst | > List . rev
2022-02-02 14:01:05 +03:00
| > List . map ( fun ( info , e ) -> ( info . var , e ) )
in
2022-01-28 13:07:29 +03:00
2022-02-04 11:27:10 +03:00
{ scopes ; decl_ctx }