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

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
(function
| "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" ->
true | _ -> false)
true
| _ -> false)
test_flags
in
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))
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

5
compiler/driver.ml
View File

@ -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

74
compiler/lcalc/closure_conversion.ml
View File

@ -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

2
compiler/shared_ast/print.ml
View File

@ -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 "<function>"
| ETuple l ->
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 =
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

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
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. *)