From dc1b725e9b9d34db3bef5da28c20a4e489b304d9 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 21 Jun 2024 12:17:31 +0200 Subject: [PATCH] Reformat --- build_system/clerk_driver.ml | 3 +- build_system/clerk_report.ml | 6 +-- compiler/driver.ml | 5 +- compiler/lcalc/closure_conversion.ml | 74 +++++++++++++++------------- compiler/shared_ast/print.ml | 2 +- compiler/shared_ast/typing.ml | 42 ++++++++-------- compiler/shared_ast/typing.mli | 3 +- 7 files changed, 71 insertions(+), 64 deletions(-) diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 6fafc759..9e7ab20f 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -489,7 +489,8 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags = List.filter (function | "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" -> - true | _ -> false) + true + | _ -> false) test_flags in let catala_flags_python = diff --git a/build_system/clerk_report.ml b/build_system/clerk_report.ml index 7ca63805..f5c1885d 100644 --- a/build_system/clerk_report.ml +++ b/build_system/clerk_report.ml @@ -124,9 +124,9 @@ let display ~build_dir file ppf t = (fun s -> if s = "--directory=" ^ build_dir then None else Some (pfile s)) t.command_line |> (function - | catala :: cmd :: args -> - (catala :: cmd :: "-I" :: Filename.dirname file :: args) - | cl -> cl) + | catala :: cmd :: args -> + catala :: cmd :: "-I" :: Filename.dirname file :: args + | cl -> cl) |> function | catala :: cmd :: args when List.mem diff --git a/compiler/driver.ml b/compiler/driver.ml index c4431660..a87bbbe0 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -281,7 +281,10 @@ module Passes = struct Message.debug "Monomorphizing types..."; let prg, type_ordering = Lcalc.Monomorphize.program prg in Message.debug "Retyping lambda calculus..."; - let prg = Typing.program ~fail_on_any:false ~assume_op_types:true ~internal_check:true prg in + let prg = + Typing.program ~fail_on_any:false ~assume_op_types:true + ~internal_check:true prg + in prg, type_ordering) else prg, type_ordering in diff --git a/compiler/lcalc/closure_conversion.ml b/compiler/lcalc/closure_conversion.ml index bc492ba9..8940e944 100644 --- a/compiler/lcalc/closure_conversion.ml +++ b/compiler/lcalc/closure_conversion.ml @@ -19,7 +19,7 @@ open Shared_ast open Ast module D = Dcalc.Ast -type name_context = { prefix: string; mutable counter: int } +type name_context = { prefix : string; mutable counter : int } type 'm ctx = { decl_ctx : decl_ctx; @@ -27,7 +27,7 @@ type 'm ctx = { globally_bound_vars : ('m expr, typ) Var.Map.t; } -let new_var ?(pfx="") name_context = +let new_var ?(pfx = "") name_context = name_context.counter <- name_context.counter + 1; Var.make (pfx ^ name_context.prefix ^ string_of_int name_context.counter) @@ -116,19 +116,15 @@ let build_closure : :: [ Expr.eappop ~op:(Operator.ToClosureEnv, pos) - ~tys: - [ - ( TTuple free_vars_types, - pos ); - ] + ~tys:[TTuple free_vars_types, pos] ~args: [ Expr.etuple - (List.map - (fun (extra_var, m) -> - Bindlib.box_var extra_var, Expr.with_pos pos m) - free_vars) - (mark_ty (TTuple free_vars_types, pos)); + (List.map + (fun (extra_var, m) -> + Bindlib.box_var extra_var, Expr.with_pos pos m) + free_vars) + (mark_ty (TTuple free_vars_types, pos)); ] (mark_ty (TClosureEnv, pos)); ]) @@ -146,28 +142,27 @@ let rec transform_closures_expr : let m = Mark.get e in match Mark.remove e with | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _ - | ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ - | ERaiseEmpty | ECatchEmpty _ -> + | ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ | ERaiseEmpty + | ECatchEmpty _ -> Expr.map_gather ~acc:Var.Map.empty ~join:join_vars ~f:(transform_closures_expr ctx) e - | EVar _ | EExternal _ as e -> ( - let body, (free_vars, fty) = match e with - | EVar v -> - Bindlib.box_var v, - (match Var.Map.find_opt v ctx.globally_bound_vars with - | None -> - Var.Map.singleton v m, None - | Some ((TArrow (targs, tret), _) as fty) -> - Var.Map.empty, Some (targs, tret, fty) - | Some _ -> - Var.Map.empty, None) + | (EVar _ | EExternal _) as e -> ( + let body, (free_vars, fty) = + match e with + | EVar v -> ( + ( Bindlib.box_var v, + match Var.Map.find_opt v ctx.globally_bound_vars with + | None -> Var.Map.singleton v m, None + | Some ((TArrow (targs, tret), _) as fty) -> + Var.Map.empty, Some (targs, tret, fty) + | Some _ -> Var.Map.empty, None )) | EExternal { name = External_value td, _ } as e -> - Bindlib.box e, - (Var.Map.empty, - match TopdefName.Map.find td ctx.decl_ctx.ctx_topdefs with - | TArrow (targs, tret), _ as fty -> Some (targs, tret, fty) - | _ -> None) + ( Bindlib.box e, + ( Var.Map.empty, + match TopdefName.Map.find td ctx.decl_ctx.ctx_topdefs with + | (TArrow (targs, tret), _) as fty -> Some (targs, tret, fty) + | _ -> None ) ) | EExternal { name = External_scope s, pos } -> let fty = let si = ScopeName.Map.find s ctx.decl_ctx.ctx_scopes in @@ -183,7 +178,10 @@ let rec transform_closures_expr : | Some (targs, tret, fty) -> (* Here we eta-expand the argument to make sure function pointers are correctly casted as closures *) - let args = Array.init (List.length targs) (fun i -> Var.make ("x"^string_of_int i)) in + let args = + Array.init (List.length targs) (fun i -> + Var.make ("x" ^ string_of_int i)) + in let arg_vars = List.map2 (fun v ty -> Expr.evar v (Expr.with_ty m ty)) @@ -409,7 +407,8 @@ let transform_closures_program (p : 'm program) : 'm program Bindlib.box = let ctx = { decl_ctx = p.decl_ctx; - name_context = new_context (Mark.remove (TopdefName.get_info name)); + name_context = + new_context (Mark.remove (TopdefName.get_info name)); globally_bound_vars = toplevel_vars; } in @@ -424,7 +423,8 @@ let transform_closures_program (p : 'm program) : 'm program Bindlib.box = let ctx = { decl_ctx = p.decl_ctx; - name_context = new_context (Mark.remove (TopdefName.get_info name)); + name_context = + new_context (Mark.remove (TopdefName.get_info name)); globally_bound_vars = toplevel_vars; } in @@ -636,7 +636,9 @@ let rec hoist_closures_code_item_list | Topdef (name, ty, (EAbs { binder; tys }, m)) -> let v, expr = Bindlib.unmbind binder in let new_hoisted_closures, new_expr = - hoist_closures_expr (new_context (Mark.remove (TopdefName.get_info name))) expr + hoist_closures_expr + (new_context (Mark.remove (TopdefName.get_info name))) + expr in let new_binder = Expr.bind v new_expr in ( new_hoisted_closures, @@ -645,7 +647,9 @@ let rec hoist_closures_code_item_list (Expr.Box.lift (Expr.eabs new_binder tys m)) ) | Topdef (name, ty, expr) -> let new_hoisted_closures, new_expr = - hoist_closures_expr (new_context (Mark.remove (TopdefName.get_info name))) expr + hoist_closures_expr + (new_context (Mark.remove (TopdefName.get_info name))) + expr in ( new_hoisted_closures, Bindlib.box_apply diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index a7e9eeb2..3d82ff1c 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -1113,7 +1113,7 @@ module UserFacing = struct ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ") (value ~fallback lang)) l - | ETuple [EAbs { tys = (TClosureEnv, _)::_ ; _ }, _; _] -> + | ETuple [(EAbs { tys = (TClosureEnv, _) :: _; _ }, _); _] -> Format.pp_print_string ppf "" | ETuple l -> Format.fprintf ppf "@[(@,@[%a@]@;<0 -2>)@]" diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 0fd92d49..302974db 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -1103,27 +1103,25 @@ let program ?fail_on_any ?assume_op_types prg = }; } -let program ?fail_on_any ?assume_op_types ?(internal_check=false) prg = +let program ?fail_on_any ?assume_op_types ?(internal_check = false) prg = let wrap = - if internal_check then - fun f -> - try Message.with_delayed_errors f with - | Message.CompilerError _ | Message.CompilerErrors _ as exc -> - let bt = Printexc.get_raw_backtrace () in - let err = match exc with - | Message.CompilerError err -> - Message.CompilerError - (Message.Content.to_internal_error err) - | Message.CompilerErrors errs -> - Message.CompilerErrors - (List.map Message.Content.to_internal_error errs) - | _ -> assert false - in - Message.debug "Faulty intermediate program:@ %a" - (Print.program ~debug:true) prg; - Printexc.raise_with_backtrace err bt - else - fun f -> Message.with_delayed_errors f + if internal_check then (fun f -> + try Message.with_delayed_errors f + with (Message.CompilerError _ | Message.CompilerErrors _) as exc -> + let bt = Printexc.get_raw_backtrace () in + let err = + match exc with + | Message.CompilerError err -> + Message.CompilerError (Message.Content.to_internal_error err) + | Message.CompilerErrors errs -> + Message.CompilerErrors + (List.map Message.Content.to_internal_error errs) + | _ -> assert false + in + Message.debug "Faulty intermediate program:@ %a" + (Print.program ~debug:true) + prg; + Printexc.raise_with_backtrace err bt) + else fun f -> Message.with_delayed_errors f in - wrap @@ fun () -> - program ?fail_on_any ?assume_op_types prg + wrap @@ fun () -> program ?fail_on_any ?assume_op_types prg diff --git a/compiler/shared_ast/typing.mli b/compiler/shared_ast/typing.mli index 7122e8e5..fb188e6c 100644 --- a/compiler/shared_ast/typing.mli +++ b/compiler/shared_ast/typing.mli @@ -107,4 +107,5 @@ val program : [Program.untype] to remove them beforehand if this is not the desired behaviour. - If [internal_check] is set to [true], typing errors will be marked as internal, and the faulty program will be printed if '--debug' is set. *) + If [internal_check] is set to [true], typing errors will be marked as + internal, and the faulty program will be printed if '--debug' is set. *)