CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 00:15:39 +03:00
Code Issues Projects Releases Wiki Activity

Restore C compilation

Browse Source
This commit is contained in:
Denis Merigoux 2024-01-17 17:26:41 +01:00
parent 5310e47e5b
commit 50d3164f36
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
3 changed files with 59 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

228
compiler/scalc/to_c.ml
View File

@ -132,35 +132,6 @@ module TypMap = Map.Make (struct
let format fmt x = Print.typ_debug fmt (x, Pos.no_pos)
end)
let option_monomorphized_instances = ref TypMap.empty
(* Returns [e_name, some_cons, none_cons] monorphized. *)
let monomorphize_enum (ctx : decl_ctx) (option_typ : typ) =
let e_name =
TypMap.find
(match Mark.remove option_typ with
| TOption t -> Mark.remove t
| _ -> failwith "should not happen")
!option_monomorphized_instances
in
let option_config =
List.map fst
(EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums))
in
let some_cons, none_cons =
match option_config with
| [c1; c2] -> (
match
( Mark.remove (EnumConstructor.get_info c1),
Mark.remove (EnumConstructor.get_info c2) )
with
| "Some", "None" -> c1, c2
| "None", "Some" -> c2, c1
| _ -> failwith "should not happen")
| _ -> failwith "should not happen"
in
e_name, some_cons, none_cons
(* Here, [element_name] is the struct field, union member or function parameter
of which you're printing the type. *)
let rec format_typ
@ -186,26 +157,15 @@ let rec format_typ
t))
(List.mapi (fun x y -> y, x) ts)
| TStruct s -> Format.fprintf fmt "%a %t" format_struct_name s element_name
| TOption some_typ ->
(* Option is a polymorphic type but C doesn't support them; we'll then have
to monomorphize everything. This printer relies on a map all of
monomorphized instances of TOption that has been pre-computed and issued
as many [typedef] in C. *)
let option_monomorphized_instance =
match
TypMap.find_opt (Mark.remove some_typ) !option_monomorphized_instances
with
| Some instance_name -> instance_name
| None -> failwith "should not happen"
in
Format.fprintf fmt "%a %t" format_enum_name option_monomorphized_instance
element_name
| TOption _ ->
Message.raise_internal_error
"All option types should have been monomorphized before compilation to C."
| TDefault t -> format_typ decl_ctx element_name fmt t
| TEnum e -> Format.fprintf fmt "%a %t" format_enum_name e element_name
| TArrow (t1, t2) ->
Format.fprintf fmt "%a (*%t)(%a)"
(format_typ decl_ctx (fun fmt -> Format.fprintf fmt "return_typ"))
t2 element_name
Format.fprintf fmt "%a(%a)"
(format_typ decl_ctx (fun fmt -> Format.fprintf fmt "(*%t)" element_name))
t2
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (i, t1_arg) ->
@ -382,20 +342,10 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
| EStructFieldAccess { e1; field; _ } ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
format_struct_field_name field
| EInj { e1 = e; cons; name = e_name; expr_typ }
(* These should only appear when initializing a variable definition *)
when EnumName.equal e_name Expr.option_enum ->
let e_name, some_cons, none_cons = monomorphize_enum ctx expr_typ in
if EnumConstructor.equal cons Expr.none_constr then
Format.fprintf fmt "{%a_%a,@ {none_cons: NULL}}" format_enum_name e_name
format_enum_cons_name none_cons
else
Format.fprintf fmt "{%a_%a,@ {some_cons: %a}}" format_enum_name e_name
format_enum_cons_name some_cons (format_expression ctx) e
| EInj { e1 = e; cons; name = enum_name; _ } ->
Format.fprintf fmt "new(\"catala_enum_%a\", code = \"%a\",@ value = %a)"
format_enum_name enum_name format_enum_cons_name cons
(format_expression ctx) e
| EInj { e1; cons; name = enum_name; _ } ->
Format.fprintf fmt "{%a_%a,@ {%a: %a}}" format_enum_name enum_name
format_enum_cons_name cons format_enum_cons_name cons
(format_expression ctx) e1
| EArray es ->
Format.fprintf fmt "list(%a)"
(Format.pp_print_list
@ -493,40 +443,6 @@ let rec format_statement
Format.fprintf fmt
"@[<hov 2>if (%a) {@\n%a@]@\n@[<hov 2>} else {@\n%a@]@\n}"
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
| SSwitch
{
switch_expr = e1;
enum_name = e_name;
switch_cases =
[
{ case_block = case_none; _ };
{ case_block = case_some; payload_var_name = case_some_var; _ };
];
switch_expr_typ;
}
when EnumName.equal e_name Expr.option_enum ->
(* Options enums have been monomorphized so now here we have to determine
which one of the instances we have to fetch *)
let e_name, some_cons, none_cons = monomorphize_enum ctx switch_expr_typ in
let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in
Format.fprintf fmt
"%a = %a;@\n\
@[<hov 2>if (%a.code == %a_%a) {@\n\
%a@]@\n\
@[<hov 2>} else {@\n\
%a = %a.payload.%a;@\n\
%a@]@\n\
}"
(format_typ ctx (fun fmt -> format_var fmt tmp_var))
switch_expr_typ (format_expression ctx) e1 format_var tmp_var
format_enum_name e_name format_enum_cons_name none_cons (format_block ctx)
case_none
(format_typ ctx (fun fmt -> format_var fmt case_some_var))
(match Mark.remove switch_expr_typ with
| TOption tau -> tau
| _ -> failwith "should not happen")
format_var tmp_var format_enum_cons_name some_cons (format_block ctx)
case_some
| SSwitch { switch_expr = e1; enum_name = e_name; switch_cases = cases; _ } ->
let cases =
List.map2
@ -565,11 +481,9 @@ let rec format_statement
(Pos.get_law_info pos)
| SSpecialOp (OHandleDefaultOpt { exceptions; just; cons; return_typ }) ->
let e_name =
TypMap.find
(match Mark.remove return_typ with
| TOption t -> Mark.remove t
| _ -> failwith "should not happen")
!option_monomorphized_instances
match Mark.remove return_typ with
| TEnum t -> t
| _ -> failwith "should not happen"
in
let option_config =
List.map fst
@ -591,9 +505,10 @@ let rec format_statement
| _ -> failwith "should not happen"
in
if exceptions <> [] then begin
Format.fprintf fmt "@[<hov 2>%a = {%a_%a,@ {none_cons: NULL}};@]@,"
Format.fprintf fmt "@[<hov 2>%a = {%a_%a,@ {%a: NULL}};@]@,"
(format_typ ctx (fun fmt -> format_var fmt exception_acc_var))
return_typ format_enum_name e_name format_enum_cons_name none_cons;
return_typ format_enum_name e_name format_enum_cons_name none_cons
format_enum_cons_name none_cons;
Format.fprintf fmt "%a;@,"
(format_typ ctx (fun fmt -> format_var fmt exception_current))
return_typ;
@ -640,11 +555,12 @@ let rec format_statement
%a@]@,\
@[<v 2>} else {@,\
%a.code = %a_%a;@,\
%a.payload.none_cons = NULL;@]@,\
%a.payload.%a = NULL;@]@,\
}"
(format_expression ctx) just (format_block ctx) cons format_var
variable_defined_in_cons format_enum_name e_name format_enum_cons_name
none_cons format_var variable_defined_in_cons;
none_cons format_var variable_defined_in_cons format_enum_cons_name
none_cons;
if exceptions <> [] then Format.fprintf fmt "@]@,}"
and format_block (ctx : decl_ctx) (fmt : Format.formatter) (b : block) : unit =
@ -652,116 +568,10 @@ and format_block (ctx : decl_ctx) (fmt : Format.formatter) (b : block) : unit =
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(format_statement ctx) fmt b
let monomorphize_option_instances (p : Ast.program) : EnumName.t TypMap.t =
let instances_counter = ref 0 in
let rec monomorphize_in_typ (acc : EnumName.t TypMap.t) (typ : typ) :
EnumName.t TypMap.t =
match Mark.remove typ with
| TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> acc
| TTuple args -> List.fold_left monomorphize_in_typ acc args
| TArray t | TDefault t -> monomorphize_in_typ acc t
| TArrow (args, ret) ->
List.fold_left monomorphize_in_typ (monomorphize_in_typ acc ret) args
| TOption t ->
let new_acc =
TypMap.update (Mark.remove t)
(fun monomorphized_name ->
match monomorphized_name with
| Some e -> Some e
| None ->
incr instances_counter;
Some
(EnumName.fresh []
("option_" ^ string_of_int !instances_counter, Pos.no_pos)))
acc
in
monomorphize_in_typ new_acc t
in
let rec monomorphize_in_block (acc : EnumName.t TypMap.t) (b : block) =
List.fold_left monomorphize_in_statement acc b
and monomorphize_in_statement (acc : EnumName.t TypMap.t) (s : stmt Mark.pos)
=
match Mark.remove s with
| SInnerFuncDef { func; _ } -> monomorphize_in_func acc func
| SLocalDecl { typ; _ } | SLocalInit { typ; _ } ->
monomorphize_in_typ acc typ
| SIfThenElse { then_block = b1; else_block = b2; _ }
| STryExcept { try_block = b1; with_block = b2; _ } ->
monomorphize_in_block (monomorphize_in_block acc b1) b2
| SRaise _ | SReturn _ | SAssert _ | SLocalDef _ -> acc
| SSwitch { switch_expr_typ; switch_cases; _ } ->
List.fold_left
(fun acc switch_case ->
monomorphize_in_block
(monomorphize_in_typ acc switch_case.payload_var_typ)
switch_case.case_block)
(monomorphize_in_typ acc switch_expr_typ)
switch_cases
| SSpecialOp (OHandleDefaultOpt { cons; return_typ; _ }) ->
monomorphize_in_block (monomorphize_in_typ acc return_typ) cons
and monomorphize_in_func (acc : EnumName.t TypMap.t) (func : func) =
monomorphize_in_block
(monomorphize_in_typ
(List.fold_left
(fun acc (_, param) -> monomorphize_in_typ acc param)
acc func.func_params)
func.func_return_typ)
func.func_body
in
List.fold_left
(fun acc code_item ->
match code_item with
| SVar { typ; _ } -> monomorphize_in_typ acc typ
| SFunc { func; _ } | SScope { scope_body_func = func; _ } ->
monomorphize_in_func acc func)
(EnumName.Map.fold
(fun _ constructors acc ->
EnumConstructor.Map.fold
(fun _ t acc -> monomorphize_in_typ acc t)
constructors acc)
p.decl_ctx.ctx_enums
(StructName.Map.fold
(fun _ fields acc ->
StructField.Map.fold
(fun _ t acc -> monomorphize_in_typ acc t)
fields acc)
p.decl_ctx.ctx_structs TypMap.empty))
p.code_items
let format_program
(fmt : Format.formatter)
(p : Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
option_monomorphized_instances := monomorphize_option_instances p;
let type_ordering =
type_ordering
@ TypMap.fold
(fun _ name acc -> Scopelang.Dependency.TVertex.Enum name :: acc)
!option_monomorphized_instances
[]
in
let p =
{
p with
decl_ctx =
{
p.decl_ctx with
ctx_enums =
TypMap.fold
(fun payload_option name acc ->
let none_constr = EnumConstructor.fresh ("None", Pos.no_pos) in
let some_constr = EnumConstructor.fresh ("Some", Pos.no_pos) in
EnumName.Map.add name
(EnumConstructor.Map.singleton none_constr
(TLit TUnit, Pos.no_pos)
|> EnumConstructor.Map.add some_constr
(payload_option, Pos.no_pos))
acc)
!option_monomorphized_instances
p.decl_ctx.ctx_enums;
};
}
in
Format.fprintf fmt
"@[<v>/* This file has been generated by the Catala compiler, do not edit! \
*/@,\

42
tests/test_backends/main.c
View File

@ -1,15 +1,48 @@
#include "simple.c"
typedef struct raw_input
{
foo_struct foo_value;
char use_foo_value;
} raw_input;
option_1_enum input_closure(void *closure_env, void *unit_arg)
{
raw_input *input = (raw_input *)closure_env;
if (input->use_foo_value)
{
option_1_enum out = {
option_1_enum_some_1_cons,
{
some_1_cons :
{bar_enum_yes_cons, {yes_cons : input->foo_value}}
}};
return out;
}
else
{
option_1_enum out = {
option_1_enum_none_1_cons,
{
none_1_cons :
NULL
}};
return out;
}
}
int main()
{
raw_input *raw_input = malloc(sizeof(raw_input));
raw_input->foo_value.x_field = 1;
raw_input->foo_value.y_field = 54;
raw_input->use_foo_value = 1;
if (!setjmp(catala_fatal_error_jump_buffer))
{
baz_in_struct input = {
{bar_enum_no_cons, {no_cons : NULL}}};
baz_in_struct input = {{input_closure, raw_input}};
baz_struct output = baz_func(input);
printf("Output: %f\n", output.b_field);
free(raw_input);
return 0;
}
else
@ -37,6 +70,7 @@ int main()
catala_fatal_error_raised.position.start_column,
catala_fatal_error_raised.position.end_line,
catala_fatal_error_raised.position.end_column);
free(raw_input);
return -1;
}
}

2
tests/test_backends/simple.catala_en
View File

@ -12,6 +12,8 @@ declaration scope Baz:
output b content decimal
scope Baz:
definition a equals No
definition b equals
match a with pattern
-- No: 0.0