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

Reformat

Browse Source
This commit is contained in:
Louis Gesbert 2024-06-21 12:17:31 +02:00
parent 812aeff736
commit dc1b725e9b
7 changed files with 71 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
build_system/clerk_driver.ml
View File

@ -489,7 +489,8 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
List.filter List.filter
(function (function
| "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" -> | "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" ->
true | _ -> false) true
| _ -> false)
test_flags test_flags
in in
let catala_flags_python = let catala_flags_python =

6
build_system/clerk_report.ml
View File

@ -124,9 +124,9 @@ let display ~build_dir file ppf t =
(fun s -> if s = "--directory=" ^ build_dir then None else Some (pfile s)) (fun s -> if s = "--directory=" ^ build_dir then None else Some (pfile s))
t.command_line t.command_line
|> (function |> (function
| catala :: cmd :: args -> | catala :: cmd :: args ->
(catala :: cmd :: "-I" :: Filename.dirname file :: args) catala :: cmd :: "-I" :: Filename.dirname file :: args
| cl -> cl) | cl -> cl)
|> function |> function
| catala :: cmd :: args | catala :: cmd :: args
when List.mem when List.mem

5
compiler/driver.ml
View File

@ -281,7 +281,10 @@ module Passes = struct
Message.debug "Monomorphizing types..."; Message.debug "Monomorphizing types...";
let prg, type_ordering = Lcalc.Monomorphize.program prg in let prg, type_ordering = Lcalc.Monomorphize.program prg in
Message.debug "Retyping lambda calculus..."; 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) prg, type_ordering)
else prg, type_ordering else prg, type_ordering
in in

74
compiler/lcalc/closure_conversion.ml
View File

@ -19,7 +19,7 @@ open Shared_ast
open Ast open Ast
module D = Dcalc.Ast module D = Dcalc.Ast
type name_context = { prefix: string; mutable counter: int } type name_context = { prefix : string; mutable counter : int }
type 'm ctx = { type 'm ctx = {
decl_ctx : decl_ctx; decl_ctx : decl_ctx;
@ -27,7 +27,7 @@ type 'm ctx = {
globally_bound_vars : ('m expr, typ) Var.Map.t; 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; name_context.counter <- name_context.counter + 1;
Var.make (pfx ^ name_context.prefix ^ string_of_int name_context.counter) Var.make (pfx ^ name_context.prefix ^ string_of_int name_context.counter)
@ -116,19 +116,15 @@ let build_closure :
:: [ :: [
Expr.eappop Expr.eappop
~op:(Operator.ToClosureEnv, pos) ~op:(Operator.ToClosureEnv, pos)
~tys: ~tys:[TTuple free_vars_types, pos]
[
( TTuple free_vars_types,
pos );
]
~args: ~args:
[ [
Expr.etuple Expr.etuple
(List.map (List.map
(fun (extra_var, m) -> (fun (extra_var, m) ->
Bindlib.box_var extra_var, Expr.with_pos pos m) Bindlib.box_var extra_var, Expr.with_pos pos m)
free_vars) free_vars)
(mark_ty (TTuple free_vars_types, pos)); (mark_ty (TTuple free_vars_types, pos));
] ]
(mark_ty (TClosureEnv, pos)); (mark_ty (TClosureEnv, pos));
]) ])
@ -146,28 +142,27 @@ let rec transform_closures_expr :
let m = Mark.get e in let m = Mark.get e in
match Mark.remove e with match Mark.remove e with
| EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _ | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _
| ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ | ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ | ERaiseEmpty
| ERaiseEmpty | ECatchEmpty _ -> | ECatchEmpty _ ->
Expr.map_gather ~acc:Var.Map.empty ~join:join_vars Expr.map_gather ~acc:Var.Map.empty ~join:join_vars
~f:(transform_closures_expr ctx) ~f:(transform_closures_expr ctx)
e e
| EVar _ | EExternal _ as e -> ( | (EVar _ | EExternal _) as e -> (
let body, (free_vars, fty) = match e with let body, (free_vars, fty) =
| EVar v -> match e with
Bindlib.box_var v, | EVar v -> (
(match Var.Map.find_opt v ctx.globally_bound_vars with ( Bindlib.box_var v,
| None -> match Var.Map.find_opt v ctx.globally_bound_vars with
Var.Map.singleton v m, None | None -> Var.Map.singleton v m, None
| Some ((TArrow (targs, tret), _) as fty) -> | Some ((TArrow (targs, tret), _) as fty) ->
Var.Map.empty, Some (targs, tret, fty) Var.Map.empty, Some (targs, tret, fty)
| Some _ -> | Some _ -> Var.Map.empty, None ))
Var.Map.empty, None)
| EExternal { name = External_value td, _ } as e -> | EExternal { name = External_value td, _ } as e ->
Bindlib.box e, ( Bindlib.box e,
(Var.Map.empty, ( Var.Map.empty,
match TopdefName.Map.find td ctx.decl_ctx.ctx_topdefs with match TopdefName.Map.find td ctx.decl_ctx.ctx_topdefs with
| TArrow (targs, tret), _ as fty -> Some (targs, tret, fty) | (TArrow (targs, tret), _) as fty -> Some (targs, tret, fty)
| _ -> None) | _ -> None ) )
| EExternal { name = External_scope s, pos } -> | EExternal { name = External_scope s, pos } ->
let fty = let fty =
let si = ScopeName.Map.find s ctx.decl_ctx.ctx_scopes in 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) -> | Some (targs, tret, fty) ->
(* Here we eta-expand the argument to make sure function pointers are (* Here we eta-expand the argument to make sure function pointers are
correctly casted as closures *) 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 = let arg_vars =
List.map2 List.map2
(fun v ty -> Expr.evar v (Expr.with_ty m ty)) (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 = let ctx =
{ {
decl_ctx = p.decl_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; globally_bound_vars = toplevel_vars;
} }
in in
@ -424,7 +423,8 @@ let transform_closures_program (p : 'm program) : 'm program Bindlib.box =
let ctx = let ctx =
{ {
decl_ctx = p.decl_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; globally_bound_vars = toplevel_vars;
} }
in in
@ -636,7 +636,9 @@ let rec hoist_closures_code_item_list
| Topdef (name, ty, (EAbs { binder; tys }, m)) -> | Topdef (name, ty, (EAbs { binder; tys }, m)) ->
let v, expr = Bindlib.unmbind binder in let v, expr = Bindlib.unmbind binder in
let new_hoisted_closures, new_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 in
let new_binder = Expr.bind v new_expr in let new_binder = Expr.bind v new_expr in
( new_hoisted_closures, ( new_hoisted_closures,
@ -645,7 +647,9 @@ let rec hoist_closures_code_item_list
(Expr.Box.lift (Expr.eabs new_binder tys m)) ) (Expr.Box.lift (Expr.eabs new_binder tys m)) )
| Topdef (name, ty, expr) -> | Topdef (name, ty, expr) ->
let new_hoisted_closures, new_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 in
( new_hoisted_closures, ( new_hoisted_closures,
Bindlib.box_apply Bindlib.box_apply

2
compiler/shared_ast/print.ml
View File

@ -1113,7 +1113,7 @@ module UserFacing = struct
~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ") ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
(value ~fallback lang)) (value ~fallback lang))
l l
| ETuple [EAbs { tys = (TClosureEnv, _)::_ ; _ }, _; _] -> | ETuple [(EAbs { tys = (TClosureEnv, _) :: _; _ }, _); _] ->
Format.pp_print_string ppf "<function>" Format.pp_print_string ppf "<function>"
| ETuple l -> | ETuple l ->
Format.fprintf ppf "@[<hv 2>(@,@[<hov>%a@]@;<0 -2>)@]" Format.fprintf ppf "@[<hv 2>(@,@[<hov>%a@]@;<0 -2>)@]"

42
compiler/shared_ast/typing.ml
View File

@ -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 = let wrap =
if internal_check then if internal_check then (fun f ->
fun f -> try Message.with_delayed_errors f
try Message.with_delayed_errors f with with (Message.CompilerError _ | Message.CompilerErrors _) as exc ->
| Message.CompilerError _ | Message.CompilerErrors _ as exc -> let bt = Printexc.get_raw_backtrace () in
let bt = Printexc.get_raw_backtrace () in let err =
let err = match exc with match exc with
| Message.CompilerError err -> | Message.CompilerError err ->
Message.CompilerError Message.CompilerError (Message.Content.to_internal_error err)
(Message.Content.to_internal_error err) | Message.CompilerErrors errs ->
| Message.CompilerErrors errs -> Message.CompilerErrors
Message.CompilerErrors (List.map Message.Content.to_internal_error errs)
(List.map Message.Content.to_internal_error errs) | _ -> assert false
| _ -> assert false in
in Message.debug "Faulty intermediate program:@ %a"
Message.debug "Faulty intermediate program:@ %a" (Print.program ~debug:true)
(Print.program ~debug:true) prg; prg;
Printexc.raise_with_backtrace err bt Printexc.raise_with_backtrace err bt)
else else fun f -> Message.with_delayed_errors f
fun f -> Message.with_delayed_errors f
in in
wrap @@ fun () -> wrap @@ fun () -> program ?fail_on_any ?assume_op_types prg
program ?fail_on_any ?assume_op_types prg

3
compiler/shared_ast/typing.mli
View File

@ -107,4 +107,5 @@ val program :
[Program.untype] to remove them beforehand if this is not the desired [Program.untype] to remove them beforehand if this is not the desired
behaviour. 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. *)