CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Closure conversion should work now

Browse Source
This commit is contained in:
Denis Merigoux 2023-06-15 17:32:00 +02:00
parent d850ac688a
commit ed2891c761
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
8 changed files with 203 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
compiler/driver.ml
View File

@ -377,7 +377,12 @@ let driver source_file (options : Cli.options) : int =
| `Interpret ->
Messages.emit_debug "Starting interpretation (dcalc)...";
let results =
Shared_ast.Interpreter.interpret_program_dcalc prgm scope_uid
try Shared_ast.Interpreter.interpret_program_dcalc prgm scope_uid
with Shared_ast.Interpreter.CatalaException exn ->
Messages.raise_error
"During interpretation, the error %a has been raised but not \
caught!"
Shared_ast.Print.except exn
in
let results =
List.sort
@ -485,7 +490,13 @@ let driver source_file (options : Cli.options) : int =
| `Interpret_Lcalc ->
Messages.emit_debug "Starting interpretation (lcalc)...";
let results =
Shared_ast.Interpreter.interpret_program_lcalc prgm scope_uid
try
Shared_ast.Interpreter.interpret_program_lcalc prgm scope_uid
with Shared_ast.Interpreter.CatalaException exn ->
Messages.raise_error
"During interpretation, the error %a has been raised but \
not caught!"
Shared_ast.Print.except exn
in
let results =
List.sort

60
compiler/lcalc/closure_conversion.ml
View File

@ -158,28 +158,38 @@ let rec transform_closures_expr :
(* x1, ..., xn *)
let code_var = Var.make ctx.name_context in
(* code *)
let inner_c_var = Var.make "env" in
let closure_env_arg_var = Var.make "env" in
let closure_env_var = Var.make "env" in
let any_ty = TAny, binder_pos in
(* let env = from_closure_env env in let arg0 = env.0 in ... *)
let new_closure_body =
Expr.make_multiple_let_in
(Array.of_list extra_vars_list)
(List.map (fun _ -> any_ty) extra_vars_list)
(List.mapi
(fun i _ ->
Expr.etupleaccess
(Expr.evar inner_c_var binder_mark)
i
(List.length extra_vars_list)
binder_mark)
extra_vars_list)
new_body
(Expr.mark_pos binder_mark)
Expr.make_let_in closure_env_var any_ty
(Expr.eapp
(Expr.eop Operator.FromClosureEnv
[TClosureEnv, binder_pos]
binder_mark)
[Expr.evar closure_env_arg_var binder_mark]
binder_mark)
(Expr.make_multiple_let_in
(Array.of_list extra_vars_list)
(List.map (fun _ -> any_ty) extra_vars_list)
(List.mapi
(fun i _ ->
Expr.etupleaccess
(Expr.evar closure_env_var binder_mark)
i
(List.length extra_vars_list)
binder_mark)
extra_vars_list)
new_body binder_pos)
binder_pos
in
(* fun env arg0 ... -> new_closure_body *)
let new_closure =
Expr.make_abs
(Array.concat [Array.make 1 inner_c_var; vars])
(Array.concat [Array.make 1 closure_env_arg_var; vars])
new_closure_body
((TAny, binder_pos) :: tys)
((TClosureEnv, binder_pos) :: tys)
(Expr.pos e)
in
( extra_vars,
@ -189,11 +199,19 @@ let rec transform_closures_expr :
(Expr.etuple
((Bindlib.box_var code_var, binder_mark)
:: [
Expr.etuple
(List.map
(fun extra_var -> Bindlib.box_var extra_var, binder_mark)
extra_vars_list)
m;
Expr.eapp
(Expr.eop Operator.ToClosureEnv
[TAny, Expr.pos e]
(Mark.get e))
[
Expr.etuple
(List.map
(fun extra_var ->
Bindlib.box_var extra_var, binder_mark)
extra_vars_list)
m;
]
(Mark.get e);
])
m)
(Expr.pos e) )

1
compiler/plugins/api_web.ml
View File

@ -83,6 +83,7 @@ module To_jsoo = struct
~pp_sep:(fun fmt () -> Format.pp_print_string fmt " -> ")
format_typ_with_parens)
t1 format_typ_with_parens t2
| TClosureEnv -> Format.fprintf fmt "Js.Unsafe.any Js.t"
let rec format_typ_to_jsoo fmt typ =
match Mark.remove typ with

2
compiler/shared_ast/interpreter.mli
View File

@ -20,6 +20,8 @@
open Catala_utils
open Definitions
exception CatalaException of except
val evaluate_operator :
((((_, _) dcalc_lcalc as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
'a operator ->

12
tests/test_func/good/closure_conversion.catala_en
View File

@ -16,18 +16,17 @@ $ catala Lcalc -s S --avoid_exceptions -O --closure_conversion
let scope S (S_in: S_in {x_in: eoption bool}): S {z: eoption integer} =
let get x : eoption bool = S_in.x_in in
let set f :
eoption
(((eoption bool), integer) → eoption integer * (eoption bool)) =
eoption ((closure_env, integer) → eoption integer * closure_env) =
ESome
(λ (env: (eoption bool)) (y: integer) →
(λ (env: closure_env) (y: integer) →
ESome
match
(match env.0 with
(match (from_closure_env env).0 with
| ENone _ → ENone _
| ESome x → if x then ESome y else ESome - y)
with
| ENone _ → raise NoValueProvided
| ESome f → f, (x))
| ESome f → f, to_closure_env (x))
in
let set z : eoption integer =
ESome
@ -36,8 +35,7 @@ let scope S (S_in: S_in {x_in: eoption bool}): S {z: eoption integer} =
| ENone _ → ENone _
| ESome f →
let code_and_env :
(((eoption bool), integer) → eoption integer *
(eoption bool)) =
((closure_env, integer) → eoption integer * closure_env) =
f
in
code_and_env.0 code_and_env.1 -1)

15
tests/test_func/good/closure_return.catala_en
View File

@ -13,26 +13,21 @@ scope S:
$ catala Lcalc -s S --avoid_exceptions -O --closure_conversion
let scope S
(S_in: S_in {x_in: eoption bool})
: S {
f:
eoption
(((eoption bool), integer) → eoption integer * (eoption bool))
}
: S {f: eoption ((closure_env, integer) → eoption integer * closure_env)}
=
let get x : eoption bool = S_in.x_in in
let set f :
eoption
(((eoption bool), integer) → eoption integer * (eoption bool)) =
eoption ((closure_env, integer) → eoption integer * closure_env) =
ESome
(λ (env: (eoption bool)) (y: integer) →
(λ (env: closure_env) (y: integer) →
ESome
match
(match env.0 with
(match (from_closure_env env).0 with
| ENone _ → ENone _
| ESome x → if x then ESome y else ESome - y)
with
| ENone _ → raise NoValueProvided
| ESome f → f, (x))
| ESome f → f, to_closure_env (x))
in
return { S f = f; }
```

8
tests/test_func/good/closure_through_scope.catala_en
View File

@ -26,13 +26,12 @@ let scope T (T_in: T_in): T {y: eoption integer} =
S {
f:
eoption
(((eoption bool), integer) → eoption integer * (eoption bool))
((closure_env, integer) → eoption integer * closure_env)
} =
ESome S { S_in x_in = ESome s.x; }
in
let sub_get s.f :
eoption
(((eoption bool), integer) → eoption integer * (eoption bool)) =
eoption ((closure_env, integer) → eoption integer * closure_env) =
match result with
| ENone _ → ENone _
| ESome result → result.f
@ -44,8 +43,7 @@ let scope T (T_in: T_in): T {y: eoption integer} =
| ENone _ → ENone _
| ESome s.f →
let code_and_env :
(((eoption bool), integer) → eoption integer *
(eoption bool)) =
((closure_env, integer) → eoption integer * closure_env) =
s.f
in
code_and_env.0 code_and_env.1 2)

165
tests/test_func/good/scope_call_func_struct_closure.catala_en
View File

@ -14,7 +14,7 @@ declaration scope SubFoo2:
declaration scope Foo:
input b content boolean
context b content boolean
internal r content Result
output z content integer
@ -26,12 +26,13 @@ scope SubFoo2:
scope Foo:
definition b equals true
definition r equals
if b then
let f equals output of SubFoo1 with { -- x: 10 } in
Result { --r: f.y --q: f.x }
else
let f equals output of SubFoo2 with { -- x1: 5 -- x2: 5 } in
let f equals output of SubFoo2 with { -- x1: 10 -- x2: 10 } in
Result { --r: f.y --q: f.x1 }
definition z equals r.r of 1
```
@ -41,33 +42,137 @@ two closures in Foo.r are different even with optimizations enabled.
TODO fix this.
```catala-test-inline
$ catala Lcalc --avoid_exceptions -O --closure_conversion
[ERROR] As part of the compilation process, one of the step (closure conversion) modified the Catala program and re-typing after this modification failed with the error message below. This re-typing error if not your fault, but is likely to indicate that the program you are trying to compile is incompatible with the current compilation scheme provided by the Catala compiler. Try to rewrite the program to avoid the problematic pattern or contact the compiler developers for help.
Error during typechecking, incompatible types:
┌─⯈ ()
└─⯈ (option integer)
Error coming from typechecking the following expression:
┌─⯈ tests/test_func/good/scope_call_func_struct_closure.catala_en:31.20-31.55:
└──┐
31 │ let f equals output of SubFoo1 with { -- x: 10 } in
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
Type () coming from expression:
┌─⯈ tests/test_func/good/scope_call_func_struct_closure.catala_en:31.20-31.55:
└──┐
31 │ let f equals output of SubFoo1 with { -- x: 10 } in
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
Type (option integer) coming from expression:
┌─⯈ tests/test_func/good/scope_call_func_struct_closure.catala_en:8.10-8.11:
└─┐
8 │ output y content integer depends on z content integer
│ ‾
#return code 255#
$ catala Lcalc --avoid_exceptions -O --closure_conversion -s Foo
let scope Foo
(Foo_in: Foo_in {b_in: eoption bool})
: Foo {z: eoption integer}
=
let get b : eoption bool = Foo_in.b_in in
let set b : eoption bool =
ESome
match
(handle_default_opt
[ b ]
(λ (_: unit) → ESome true)
(λ (_: unit) → ESome true))
with
| ENone _ → raise NoValueProvided
| ESome b → b
in
let set r :
eoption
Result {
r:
eoption
((closure_env, integer) → eoption integer * closure_env);
q: eoption integer
} =
ESome
match
(match b with
| ENone _ → ENone _
| ESome b →
if b
then
match
(match (SubFoo1 { SubFoo1_in x_in = ESome 10; }).x with
| ENone _ → ENone _
| ESome result_0 →
ESome
{ SubFoo1
x = ESome result_0;
y =
ESome
(λ (env: closure_env) (param0: integer) →
match
(SubFoo1 { SubFoo1_in x_in = ESome 10; }).y
with
| ENone _ → ENone _
| ESome result →
let code_and_env :
((closure_env, integer) → eoption integer *
closure_env) =
result
in
code_and_env.0 code_and_env.1 param0,
to_closure_env ());
})
with
| ENone _ → ENone _
| ESome f →
match f.x with
| ENone _ → ENone _
| ESome f_1 →
match f.y with
| ENone _ → ENone _
| ESome f_0 → ESome { Result r = ESome f_0; q = ESome f_1; }
else
match
(match
(SubFoo2 { SubFoo2_in x1_in = ESome 10; x2_in = ESome 10; }).
x1
with
| ENone _ → ENone _
| ESome result_0 →
ESome
{ SubFoo2
x1 = ESome result_0;
y =
ESome
(λ (env: closure_env) (param0: integer) →
match
(SubFoo2
{ SubFoo2_in
x1_in = ESome 10;
x2_in = ESome 10;
}).
y
with
| ENone _ → ENone _
| ESome result →
let code_and_env :
((closure_env, integer) → eoption integer *
closure_env) =
result
in
code_and_env.0 code_and_env.1 param0,
to_closure_env ());
})
with
| ENone _ → ENone _
| ESome f →
match f.x1 with
| ENone _ → ENone _
| ESome f_1 →
match f.y with
| ENone _ → ENone _
| ESome f_0 → ESome { Result r = ESome f_0; q = ESome f_1; })
with
| ENone _ → raise NoValueProvided
| ESome r → r
in
let set z : eoption integer =
ESome
match
(match (match r with
| ENone _ → ENone _
| ESome r → r.r) with
| ENone _ → ENone _
| ESome r →
let code_and_env :
((closure_env, integer) → eoption integer * closure_env) =
r
in
code_and_env.0 code_and_env.1 1)
with
| ENone _ → raise NoValueProvided
| ESome z → z
in
return { Foo z = z; }
```
```catala-test-inline
$ catala Interpret_lcalc -s Foo --avoid_exceptions -O --closure_conversion
[RESULT] Computation successful! Results:
[RESULT] z = ESome 11
```