CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-16 14:57:13 +03:00
Code Issues Projects Releases Wiki Activity

reformat (renaming in scalc)

Browse Source
This commit is contained in:
Louis Gesbert 2024-08-07 17:44:39 +02:00
parent 1230f787d6
commit 1b6da0b572
10 changed files with 191 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
compiler/driver.ml
View File

@ -230,9 +230,9 @@ module Passes = struct
~closure_conversion
~monomorphize_types
~renaming :
typed Lcalc.Ast.program *
Scopelang.Dependency.TVertex.t list *
Expr.Renaming.context option =
typed Lcalc.Ast.program
* Scopelang.Dependency.TVertex.t list
* Expr.Renaming.context option =
let prg, type_ordering =
dcalc options ~includes ~optimize ~check_invariants ~typed
in
@ -303,25 +303,35 @@ module Passes = struct
~no_struct_literals
~monomorphize_types
~renaming :
Scalc.Ast.program * Scopelang.Dependency.TVertex.t list * Expr.Renaming.context =
Scalc.Ast.program
* Scopelang.Dependency.TVertex.t list
* Expr.Renaming.context =
let prg, type_ordering, renaming_context =
lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed
~closure_conversion ~monomorphize_types ~renaming
in
let renaming_context = match renaming_context with
| None -> Expr.Renaming.get_ctx {
reserved = [];
sanitize_varname = Fun.id;
reset_context_for_closed_terms = true;
skip_constant_binders = true;
constant_binder_name = None;
}
let renaming_context =
match renaming_context with
| None ->
Expr.Renaming.get_ctx
{
reserved = [];
sanitize_varname = Fun.id;
reset_context_for_closed_terms = true;
skip_constant_binders = true;
constant_binder_name = None;
}
| Some r -> r
in
debug_pass_name "scalc";
( Scalc.From_lcalc.translate_program
~config:{ keep_special_ops; dead_value_assignment; no_struct_literals;
renaming_context }
~config:
{
keep_special_ops;
dead_value_assignment;
no_struct_literals;
renaming_context;
}
prg,
type_ordering,
renaming_context )
@ -963,8 +973,7 @@ module Commands = struct
Passes.scalc options ~includes ~optimize ~check_invariants
~closure_conversion:true ~keep_special_ops:true
~dead_value_assignment:false ~no_struct_literals:true
~monomorphize_types:true
~renaming:(Some Scalc.To_c.renaming)
~monomorphize_types:true ~renaming:(Some Scalc.To_c.renaming)
in
let output_file, with_output = get_output_format options ~ext:".c" output in
Message.debug "Compiling program into C...";

15
compiler/driver.mli
View File

@ -53,9 +53,10 @@ module Passes : sig
typed:'m Shared_ast.mark ->
closure_conversion:bool ->
monomorphize_types:bool ->
renaming : Shared_ast.Program.renaming option ->
Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list *
Shared_ast.Expr.Renaming.context option
renaming:Shared_ast.Program.renaming option ->
Shared_ast.typed Lcalc.Ast.program
* Scopelang.Dependency.TVertex.t list
* Shared_ast.Expr.Renaming.context option
val scalc :
Global.options ->
@ -67,10 +68,10 @@ module Passes : sig
dead_value_assignment:bool ->
no_struct_literals:bool ->
monomorphize_types:bool ->
renaming: Shared_ast.Program.renaming option ->
Scalc.Ast.program * Scopelang.Dependency.TVertex.t list *
Shared_ast.Expr.Renaming.context
renaming:Shared_ast.Program.renaming option ->
Scalc.Ast.program
* Scopelang.Dependency.TVertex.t list
* Shared_ast.Expr.Renaming.context
end
module Commands : sig

2
compiler/lcalc/to_ocaml.ml
View File

@ -133,7 +133,7 @@ let ocaml_keywords =
let renaming =
Program.renaming ()
~reserved:ocaml_keywords
(* TODO: add catala runtime built-ins as reserved as well ? *)
(* TODO: add catala runtime built-ins as reserved as well ? *)
~reset_context_for_closed_terms:true ~skip_constant_binders:true
~constant_binder_name:(Some "_") ~namespaced_fields_constrs:true

98
compiler/scalc/from_lcalc.ml
View File

@ -173,8 +173,7 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr =
let vars, body, ctxt = unmbind ctxt binder in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) tys in
let ctxt =
List.fold_left (register_fresh_arg ~pos:binder_pos)
ctxt vars_tau
List.fold_left (register_fresh_arg ~pos:binder_pos) ctxt vars_tau
in
let local_decls =
List.fold_left
@ -336,9 +335,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
let vars, body, ctxt = unmbind ctxt binder in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) tys in
let ctxt =
List.fold_left
(register_fresh_arg ~pos:binder_pos)
ctxt vars_tau
List.fold_left (register_fresh_arg ~pos:binder_pos) ctxt vars_tau
in
let local_decls =
List.map
@ -557,12 +554,9 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
RevBlock.rebuild e_stmts ~tail
| _ -> .
let rec translate_scope_body_expr
ctx
(scope_expr : 'm L.expr scope_body_expr) : A.block =
let ctx =
{ ctx with inside_definition_of = None }
in
let rec translate_scope_body_expr ctx (scope_expr : 'm L.expr scope_body_expr) :
A.block =
let ctx = { ctx with inside_definition_of = None } in
match scope_expr with
| Last e ->
let block, new_e = translate_expr ctx e in
@ -572,9 +566,7 @@ let rec translate_scope_body_expr
let let_var_id, ctx =
register_fresh_var ctx1 let_var ~pos:scope_let.scope_let_pos
in
let next =
translate_scope_body_expr ctx scope_let_next
in
let next = translate_scope_body_expr ctx scope_let_next in
match scope_let.scope_let_kind with
| Assertion ->
translate_statements
@ -604,7 +596,7 @@ let rec translate_scope_body_expr
scope_let.scope_let_pos )
:: next))
let translate_program ~(config : translation_config) (p : 'm L.program):
let translate_program ~(config : translation_config) (p : 'm L.program) :
A.program =
let modules =
List.fold_left
@ -632,8 +624,7 @@ let translate_program ~(config : translation_config) (p : 'm L.program):
}
in
let (_, rev_items), _vlist =
BoundList.fold_left
~init:(ctxt, [])
BoundList.fold_left ~init:(ctxt, [])
~f:(fun (ctxt, rev_items) code_item var ->
match code_item with
| ScopeDef (name, body) ->
@ -646,13 +637,10 @@ let translate_program ~(config : translation_config) (p : 'm L.program):
in
let new_scope_body =
translate_scope_body_expr
{ ctxt with
context_name = Mark.remove (ScopeName.get_info name) }
{ ctxt with context_name = Mark.remove (ScopeName.get_info name) }
scope_body_expr
in
let func_id, ctxt1 =
register_fresh_func ctxt1 var ~pos:input_pos
in
let func_id, ctxt1 = register_fresh_func ctxt1 var ~pos:input_pos in
( ctxt1,
A.SScope
{
@ -679,13 +667,14 @@ let translate_program ~(config : translation_config) (p : 'm L.program):
let rargs_id, ctxt =
List.fold_left2
(fun (rargs_id, ctxt) v ty ->
let pos = Mark.get ty in
let id, ctxt = register_fresh_var ctxt v ~pos in
((id, pos), ty) :: rargs_id, ctxt)
let pos = Mark.get ty in
let id, ctxt = register_fresh_var ctxt v ~pos in
((id, pos), ty) :: rargs_id, ctxt)
([], ctxt) args abs.tys
in
let ctxt =
{ ctxt with
{
ctxt with
context_name = Mark.remove (TopdefName.get_info name);
}
in
@ -695,7 +684,9 @@ let translate_program ~(config : translation_config) (p : 'm L.program):
RevBlock.rebuild block
~tail:[A.SReturn (Mark.remove expr), Mark.get expr]
in
let func_id, ctxt = register_fresh_func ctxt var ~pos:(Expr.mark_pos m) in
let func_id, ctxt =
register_fresh_func ctxt var ~pos:(Expr.mark_pos m)
in
( ctxt,
A.SFunc
{
@ -716,14 +707,16 @@ let translate_program ~(config : translation_config) (p : 'm L.program):
(* Toplevel constant def *)
let block, expr =
let ctxt =
{ ctxt with
{
ctxt with
context_name = Mark.remove (TopdefName.get_info name);
}
in
translate_expr ctxt expr
in
let var_id, ctxt =
register_fresh_var ctxt var ~pos:(Mark.get (TopdefName.get_info name))
register_fresh_var ctxt var
~pos:(Mark.get (TopdefName.get_info name))
in
(* If the evaluation of the toplevel expr requires preliminary
statements, we lift its computation into an auxiliary function *)
@ -738,26 +731,27 @@ let translate_program ~(config : translation_config) (p : 'm L.program):
let func_id = A.FuncName.fresh (func_name, pos) in
(* The list is being built in reverse order *)
(* FIXME: find a better way than a function with no parameters... *)
A.SVar
{
var = var_id;
expr = A.EApp { f = EFunc func_id, pos; args = [] }, pos;
typ = topdef_ty;
}
:: A.SFunc
{
var = func_id;
func =
{
A.func_params = [];
A.func_body =
RevBlock.rebuild block
~tail:[A.SReturn (Mark.remove expr), Mark.get expr];
A.func_return_typ = topdef_ty;
};
}
:: rev_items,
ctxt
( A.SVar
{
var = var_id;
expr = A.EApp { f = EFunc func_id, pos; args = [] }, pos;
typ = topdef_ty;
}
:: A.SFunc
{
var = func_id;
func =
{
A.func_params = [];
A.func_body =
RevBlock.rebuild block
~tail:
[A.SReturn (Mark.remove expr), Mark.get expr];
A.func_return_typ = topdef_ty;
};
}
:: rev_items,
ctxt )
in
( ctxt,
(* No need to add func_id since the function will only be called
@ -765,4 +759,8 @@ let translate_program ~(config : translation_config) (p : 'm L.program):
rev_items ))
p.code_items
in
{ ctx = program_ctx; code_items = List.rev rev_items; module_name = p.module_name }
{
ctx = program_ctx;
code_items = List.rev rev_items;
module_name = p.module_name;
}

3
compiler/scalc/from_lcalc.mli
View File

@ -36,5 +36,4 @@ type translation_config = {
}
val translate_program :
config:translation_config -> typed Lcalc.Ast.program ->
Ast.program
config:translation_config -> typed Lcalc.Ast.program -> Ast.program

4
compiler/scalc/print.ml
View File

@ -22,11 +22,11 @@ let needs_parens (_e : expr) : bool = false
let format_var_name (fmt : Format.formatter) (v : VarName.t) : unit =
VarName.format fmt v
(* Format.fprintf fmt "%a_%d" VarName.format v (VarName.id v) *)
(* Format.fprintf fmt "%a_%d" VarName.format v (VarName.id v) *)
let format_func_name (fmt : Format.formatter) (v : FuncName.t) : unit =
FuncName.format fmt v
(* Format.fprintf fmt "@{<green>%a_%d@}" FuncName.format v (FuncName.id v) *)
(* Format.fprintf fmt "@{<green>%a_%d@}" FuncName.format v (FuncName.id v) *)
let rec format_expr
(decl_ctx : decl_ctx)

65
compiler/scalc/to_c.ml
View File

@ -22,20 +22,49 @@ module L = Lcalc.Ast
open Ast
let c_keywords =
[ "auto"; "break"; "case"; "char"; "const"; "continue"; "default";
"do"; "double"; "else"; "enum"; "extern"; "float"; "for"; "goto";
"if"; "inline"; "int"; "long"; "register"; "restrict"; "return";
"short"; "signed"; "sizeof"; "static"; "struct"; "switch"; "typedef";
"union"; "unsigned"; "void"; "volatile"; "while" ]
[
"auto";
"break";
"case";
"char";
"const";
"continue";
"default";
"do";
"double";
"else";
"enum";
"extern";
"float";
"for";
"goto";
"if";
"inline";
"int";
"long";
"register";
"restrict";
"return";
"short";
"signed";
"sizeof";
"static";
"struct";
"switch";
"typedef";
"union";
"unsigned";
"void";
"volatile";
"while";
]
let renaming =
Program.renaming ()
~reserved:c_keywords
(* TODO: add catala runtime built-ins as reserved as well ? *)
~reset_context_for_closed_terms:true
~skip_constant_binders:true
~constant_binder_name:None
~namespaced_fields_constrs:false
(* TODO: add catala runtime built-ins as reserved as well ? *)
~reset_context_for_closed_terms:true ~skip_constant_binders:true
~constant_binder_name:None ~namespaced_fields_constrs:false
module TypMap = Map.Make (struct
type t = naked_typ
@ -102,8 +131,7 @@ let format_ctx
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "@[<v>%a;@]"
(format_typ ctx (fun fmt ->
StructField.format fmt struct_field))
(format_typ ctx (fun fmt -> StructField.format fmt struct_field))
struct_field_type))
fields StructName.format struct_name
in
@ -251,8 +279,8 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
(fun fmt (_, e) -> Format.fprintf fmt "%a" (format_expression ctx) e))
(StructField.Map.bindings es)
| EStructFieldAccess { e1; field; _ } ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
StructField.format field
Format.fprintf fmt "%a.%a" (format_expression ctx) e1 StructField.format
field
| EInj { e1; cons; name = enum_name; _ } ->
Format.fprintf fmt "{%a_%a,@ {%a: %a}}" EnumName.format enum_name
EnumConstructor.format cons EnumConstructor.format cons
@ -380,7 +408,8 @@ let rec format_statement
if not (Type.equal payload_var_typ (TLit TUnit, Pos.no_pos)) then
Format.fprintf fmt "%a = %a.payload.%a;@ "
(format_typ ctx (fun fmt -> VarName.format fmt payload_var_name))
payload_var_typ VarName.format tmp_var EnumConstructor.format cons_name;
payload_var_typ VarName.format tmp_var EnumConstructor.format
cons_name;
Format.fprintf fmt "%a@ break;@]" (format_block ctx) case_block)
fmt cases;
(* Do we want to add 'default' case with a failure ? *)
@ -447,9 +476,9 @@ let rec format_statement
VarName.format exception_current (format_expression ctx) except
VarName.format exception_current EnumName.format e_name
EnumConstructor.format some_cons VarName.format exception_acc_var
EnumName.format e_name EnumConstructor.format some_cons VarName.format
exception_conflict VarName.format exception_acc_var VarName.format
exception_current)
EnumName.format e_name EnumConstructor.format some_cons
VarName.format exception_conflict VarName.format exception_acc_var
VarName.format exception_current)
exceptions;
Format.fprintf fmt
"@[<v 2>if (%a) {@,\

63
compiler/scalc/to_python.ml
View File

@ -113,17 +113,50 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
let python_keywords =
(* list taken from
https://www.programiz.com/python-programming/keyword-list *)
[ "False"; "None"; "True"; "and"; "as"; "assert"; "async"; "await";
"break"; "class"; "continue"; "def"; "del"; "elif"; "else";
"except"; "finally"; "for"; "from"; "global"; "if"; "import"; "in";
"is"; "lambda"; "nonlocal"; "not"; "or"; "pass"; "raise"; "return";
"try"; "while"; "with"; "yield" ]
(* todo: reserved names should also include built-in types and everything exposed by the runtime. *)
[
"False";
"None";
"True";
"and";
"as";
"assert";
"async";
"await";
"break";
"class";
"continue";
"def";
"del";
"elif";
"else";
"except";
"finally";
"for";
"from";
"global";
"if";
"import";
"in";
"is";
"lambda";
"nonlocal";
"not";
"or";
"pass";
"raise";
"return";
"try";
"while";
"with";
"yield";
]
(* todo: reserved names should also include built-in types and everything
exposed by the runtime. *)
let renaming =
Program.renaming ()
~reserved:python_keywords
(* TODO: add catala runtime built-ins as reserved as well ? *)
(* TODO: add catala runtime built-ins as reserved as well ? *)
~reset_context_for_closed_terms:false ~skip_constant_binders:false
~constant_binder_name:None ~namespaced_fields_constrs:true
~f_struct:String.to_camel_case
@ -198,8 +231,8 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(format_expression ctx) e))
(StructField.Map.bindings es)
| EStructFieldAccess { e1; field; _ } ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
StructField.format field
Format.fprintf fmt "%a.%a" (format_expression ctx) e1 StructField.format
field
| EInj { cons; name = e_name; _ }
when EnumName.equal e_name Expr.option_enum
&& EnumConstructor.equal cons Expr.none_constr ->
@ -352,8 +385,8 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit
(format_expression ctx) e1;
Format.fprintf fmt "@[<v 4>if %a is None:@ %a@]@," VarName.format tmp_var
(format_block ctx) case_none;
Format.fprintf fmt "@[<v 4>else:@ %a = %a@,%a@]" VarName.format case_some_var
VarName.format tmp_var (format_block ctx) case_some
Format.fprintf fmt "@[<v 4>else:@ %a = %a@,%a@]" VarName.format
case_some_var VarName.format tmp_var (format_block ctx) case_some
| SSwitch { switch_expr = e1; enum_name = e_name; switch_cases = cases; _ } ->
let cons_map = EnumName.Map.find e_name ctx.decl_ctx.ctx_enums in
let cases =
@ -369,7 +402,7 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit
~pp_sep:(fun fmt () -> Format.fprintf fmt "@]@\n@[<hov 4>elif ")
(fun fmt ({ case_block; payload_var_name; _ }, cons_name) ->
Format.fprintf fmt "%a.code == %a_Code.%a:@\n%a = %a.value@\n%a"
VarName.format tmp_var (EnumName.format) e_name
VarName.format tmp_var EnumName.format e_name
EnumConstructor.format cons_name VarName.format payload_var_name
VarName.format tmp_var (format_block ctx) case_block))
cases
@ -482,14 +515,14 @@ let format_ctx
@,\
\ def __str__(self) -> str:@,\
\ @[<hov 4>return \"{}({})\".format(self.code, self.value)@]"
(EnumName.format) enum_name
EnumName.format enum_name
(Format.pp_print_list (fun fmt (i, enum_cons, _enum_cons_type) ->
Format.fprintf fmt "%a = %d" EnumConstructor.format enum_cons i))
(List.mapi
(fun i (x, y) -> i, x, y)
(EnumConstructor.Map.bindings enum_cons))
(EnumName.format) enum_name EnumName.format enum_name
EnumName.format enum_name
EnumName.format enum_name EnumName.format enum_name EnumName.format
enum_name
in
let is_in_type_ordering s =

32
compiler/shared_ast/program.ml
View File

@ -114,8 +114,7 @@ let rename_ids
?(f_field = uncap)
?(f_enum = cap)
?(f_constr = cap)
p
=
p =
let cfg =
{
Expr.Renaming.reserved;
@ -285,17 +284,16 @@ let rename_ids
let code_items = Scope.rename_ids ctx p.code_items in
{ p with decl_ctx; code_items }, ctx
(* This first-class module wrapping is here to allow a polymorphic renaming function to be passed around *)
(* This first-class module wrapping is here to allow a polymorphic renaming
function to be passed around *)
module type Renaming = sig
val apply:
'e program ->
'e program * Expr.Renaming.context
val apply : 'e program -> 'e program * Expr.Renaming.context
end
type renaming = (module Renaming)
let apply (module R: Renaming) = R.apply
let apply (module R : Renaming) = R.apply
let renaming
~reserved
@ -308,21 +306,11 @@ let renaming
?f_field
?f_enum
?f_constr
()
=
() =
let module M = struct
let apply p =
rename_ids
~reserved
~reset_context_for_closed_terms
~skip_constant_binders
~constant_binder_name
~namespaced_fields_constrs
?f_var
?f_struct
?f_field
?f_enum
?f_constr
p
rename_ids ~reserved ~reset_context_for_closed_terms
~skip_constant_binders ~constant_binder_name ~namespaced_fields_constrs
?f_var ?f_struct ?f_field ?f_enum ?f_constr p
end in
(module M: Renaming)
(module M : Renaming)

2
compiler/shared_ast/program.mli
View File

@ -59,7 +59,7 @@ val modules_to_list : module_tree -> (ModuleName.t * module_intf_id) list
type renaming
val apply: renaming -> 'e program -> 'e program * Expr.Renaming.context
val apply : renaming -> 'e program -> 'e program * Expr.Renaming.context
val renaming :
reserved:string list ->