From 1b6da0b5720e9168aca1452e9ed40ad7e0bd737a Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 7 Aug 2024 17:44:39 +0200 Subject: [PATCH] reformat (renaming in scalc) --- compiler/driver.ml | 41 ++++++++------ compiler/driver.mli | 15 ++--- compiler/lcalc/to_ocaml.ml | 2 +- compiler/scalc/from_lcalc.ml | 98 ++++++++++++++++----------------- compiler/scalc/from_lcalc.mli | 3 +- compiler/scalc/print.ml | 4 +- compiler/scalc/to_c.ml | 65 ++++++++++++++++------ compiler/scalc/to_python.ml | 63 ++++++++++++++++----- compiler/shared_ast/program.ml | 32 ++++------- compiler/shared_ast/program.mli | 2 +- 10 files changed, 191 insertions(+), 134 deletions(-) diff --git a/compiler/driver.ml b/compiler/driver.ml index 862858ca..852707b1 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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..."; diff --git a/compiler/driver.mli b/compiler/driver.mli index 47f2bfce..372b19e1 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -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 diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index d9e5f68e..d1a783ba 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -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 diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index c3326954..cbf65fe6 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -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; + } diff --git a/compiler/scalc/from_lcalc.mli b/compiler/scalc/from_lcalc.mli index 4cd09de7..7ab7f417 100644 --- a/compiler/scalc/from_lcalc.mli +++ b/compiler/scalc/from_lcalc.mli @@ -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 diff --git a/compiler/scalc/print.ml b/compiler/scalc/print.ml index a40737c6..03bf5fa2 100644 --- a/compiler/scalc/print.ml +++ b/compiler/scalc/print.ml @@ -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 "@{%a_%d@}" FuncName.format v (FuncName.id v) *) +(* Format.fprintf fmt "@{%a_%d@}" FuncName.format v (FuncName.id v) *) let rec format_expr (decl_ctx : decl_ctx) diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 517db4ae..77841ed7 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -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 "@[%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 "@[if (%a) {@,\ diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index 26f33765..2391a4f1 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -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 "@[if %a is None:@ %a@]@," VarName.format tmp_var (format_block ctx) case_none; - Format.fprintf fmt "@[else:@ %a = %a@,%a@]" VarName.format case_some_var - VarName.format tmp_var (format_block ctx) case_some + Format.fprintf fmt "@[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@[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:@,\ \ @[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 = diff --git a/compiler/shared_ast/program.ml b/compiler/shared_ast/program.ml index 33062c64..b76d1e84 100644 --- a/compiler/shared_ast/program.ml +++ b/compiler/shared_ast/program.ml @@ -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) diff --git a/compiler/shared_ast/program.mli b/compiler/shared_ast/program.mli index 7fd58a3b..41880a03 100644 --- a/compiler/shared_ast/program.mli +++ b/compiler/shared_ast/program.mli @@ -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 ->