CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Remove RaiseEmpty and CatchEmpty from the AST

Browse Source
This commit is contained in:
Louis Gesbert 2024-06-24 18:24:47 +02:00
parent 6cb19b4f0b
commit 88f5e932c8
12 changed files with 60 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
compiler/lcalc/closure_conversion.ml
View File

@ -146,8 +146,7 @@ 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 _ ->
Expr.map_gather ~acc:Var.Map.empty ~join:join_vars
~f:(transform_closures_expr ctx)
e
@ -575,7 +574,7 @@ let rec hoist_closures_expr :
Expr.make_var closure_var m )
| EApp _ | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _
| EArray _ | ELit _ | EAssert _ | EFatalError _ | EAppOp _ | EIfThenElse _
| ERaiseEmpty | ECatchEmpty _ | EVar _ ->
| EVar _ ->
Expr.map_gather ~acc:[] ~join:( @ ) ~f:(hoist_closures_expr name_context) e
| EExternal { name } -> [], Expr.box (EExternal { name }, m)
| _ -> .

4
compiler/lcalc/to_ocaml.ml
View File

@ -463,10 +463,6 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
| EFatalError er ->
Format.fprintf fmt "raise@ (Runtime_ocaml.Runtime.Error (%a, [%a]))"
Print.runtime_error er format_pos (Expr.pos e)
| ERaiseEmpty -> Format.fprintf fmt "raise Empty"
| ECatchEmpty { body; handler } ->
Format.fprintf fmt "@[<hv>@[<hov 2>try@ %a@]@ with Empty ->@]@ @[%a@]"
format_with_parens body format_with_parens handler
| _ -> .
let format_struct_embedding

26
compiler/scalc/from_lcalc.ml
View File

@ -227,8 +227,7 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr =
Expr.pos expr )
in
RevBlock.empty, (EExternal { modname; name }, Expr.pos expr)
| ECatchEmpty _ | EAbs _ | EIfThenElse _ | EMatch _ | EAssert _
| EFatalError _ | ERaiseEmpty ->
| EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ | EFatalError _ ->
raise (NotAnExpr { needs_a_local_decl = true })
| _ -> .
with NotAnExpr { needs_a_local_decl } ->
@ -483,29 +482,6 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
},
Expr.pos block_expr );
]
| ECatchEmpty { body; handler } ->
let s_e_try = translate_statements ctxt body in
let s_e_catch = translate_statements ctxt handler in
[
( A.STryWEmpty { try_block = s_e_try; with_block = s_e_catch },
Expr.pos block_expr );
]
| ERaiseEmpty ->
(* Before raising the exception, we still give a dummy definition to the
current variable so that tools like mypy don't complain. *)
(match ctxt.inside_definition_of with
| Some x when ctxt.config.dead_value_assignment ->
[
( A.SLocalDef
{
name = x, Expr.pos block_expr;
expr = Ast.EVar Ast.dead_value, Expr.pos block_expr;
typ = Expr.maybe_ty (Mark.get block_expr);
},
Expr.pos block_expr );
]
| _ -> [])
@ [A.SRaiseEmpty, Expr.pos block_expr]
| EInj { e = e1; cons; name } when ctxt.config.no_struct_literals ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let tmp_struct_var_name =

18
compiler/shared_ast/definitions.ml
View File

@ -138,7 +138,6 @@ type desugared =
; explicitScopes : yes
; assertions : no
; defaultTerms : yes
; exceptions : no
; custom : no >
(* Technically, desugared before name resolution has [syntacticNames: yes;
resolvedNames: no], and after name resolution has the opposite; but the
@ -159,7 +158,6 @@ type scopelang =
; explicitScopes : yes
; assertions : no
; defaultTerms : yes
; exceptions : no
; custom : no >
type dcalc =
@ -173,7 +171,6 @@ type dcalc =
; explicitScopes : no
; assertions : yes
; defaultTerms : yes
; exceptions : no
; custom : no >
type lcalc =
@ -187,7 +184,6 @@ type lcalc =
; explicitScopes : no
; assertions : yes
; defaultTerms : no
; exceptions : yes
; custom : no >
type 'a any = < .. > as 'a
@ -206,12 +202,11 @@ type dcalc_lcalc_features =
; assertions : yes >
(** Features that are common to Dcalc and Lcalc *)
type ('a, 'b) dcalc_lcalc =
< dcalc_lcalc_features ; defaultTerms : 'a ; exceptions : 'b ; custom : no >
type 'd dcalc_lcalc = < dcalc_lcalc_features ; defaultTerms : 'd ; custom : no >
(** This type regroups Dcalc and Lcalc ASTs. *)
type ('a, 'b, 'c) interpr_kind =
< dcalc_lcalc_features ; defaultTerms : 'a ; exceptions : 'b ; custom : 'c >
type ('d, 'c) interpr_kind =
< dcalc_lcalc_features ; defaultTerms : 'd ; custom : 'c >
(** This type corresponds to the types handled by the interpreter: it regroups
Dcalc and Lcalc ASTs and may have custom terms *)
@ -562,13 +557,6 @@ and ('a, 'b, 'm) base_gexpr =
| EErrorOnEmpty :
('a, 'm) gexpr
-> ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr
(* Lambda calculus with exceptions *)
| ERaiseEmpty : ('a, < exceptions : yes ; .. >, 'm) base_gexpr
| ECatchEmpty : {
body : ('a, 'm) gexpr;
handler : ('a, 'm) gexpr;
}
-> ('a, < exceptions : yes ; .. >, 'm) base_gexpr
(* Only used during evaluation *)
| ECustom : {
obj : Obj.t;

40
compiler/shared_ast/expr.ml
View File

@ -145,10 +145,6 @@ let eifthenelse cond etrue efalse =
let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> EErrorOnEmpty e1
let eempty mark = Mark.add mark (Bindlib.box EEmpty)
let eraiseempty mark = Mark.add mark (Bindlib.box ERaiseEmpty)
let ecatchempty body handler =
Box.app2 body handler @@ fun body handler -> ECatchEmpty { body; handler }
let ecustom obj targs tret mark =
Mark.add mark (Bindlib.box (ECustom { obj; targs; tret }))
@ -333,8 +329,6 @@ let map
| EPureDefault e1 -> epuredefault (f e1) m
| EEmpty -> eempty m
| EErrorOnEmpty e1 -> eerroronempty (f e1) m
| ECatchEmpty { body; handler } -> ecatchempty (f body) (f handler) m
| ERaiseEmpty -> eraiseempty m
| ELocation loc -> elocation loc m
| EStruct { name; fields } ->
let fields = StructField.Map.map f fields in
@ -365,9 +359,7 @@ let shallow_fold
(acc : 'acc) : 'acc =
let lfold x acc = List.fold_left (fun acc x -> f x acc) acc x in
match Mark.remove e with
| ELit _ | EVar _ | EFatalError _ | EExternal _ | ERaiseEmpty | ELocation _
| EEmpty ->
acc
| ELit _ | EVar _ | EFatalError _ | EExternal _ | ELocation _ | EEmpty -> acc
| EApp { f = e; args; _ } -> acc |> f e |> lfold args
| EAppOp { args; _ } -> acc |> lfold args
| EArray args -> acc |> lfold args
@ -382,7 +374,6 @@ let shallow_fold
| EDefault { excepts; just; cons } -> acc |> lfold excepts |> f just |> f cons
| EPureDefault e -> acc |> f e
| EErrorOnEmpty e -> acc |> f e
| ECatchEmpty { body; handler } -> acc |> f body |> f handler
| EStruct { fields; _ } -> acc |> StructField.Map.fold (fun _ -> f) fields
| EDStructAmend { e; fields; _ } ->
acc |> f e |> Ident.Map.fold (fun _ -> f) fields
@ -460,11 +451,6 @@ let map_gather
| EErrorOnEmpty e ->
let acc, e = f e in
acc, eerroronempty e m
| ECatchEmpty { body; handler } ->
let acc1, body = f body in
let acc2, handler = f handler in
join acc1 acc2, ecatchempty body handler m
| ERaiseEmpty -> acc, eraiseempty m
| ELocation loc -> acc, elocation loc m
| EStruct { name; fields } ->
let acc, fields =
@ -532,7 +518,7 @@ let untype e = map_marks ~f:(fun m -> Untyped { pos = mark_pos m }) e
let is_value (type a) (e : (a, _) gexpr) =
match Mark.remove e with
| ELit _ | EAbs _ | ERaiseEmpty | ECustom _ | EExternal _ -> true
| ELit _ | EAbs _ | ECustom _ | EExternal _ -> true
| _ -> false
let equal_lit (l1 : lit) (l2 : lit) =
@ -664,10 +650,6 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
equal if1 if2 && equal then1 then2 && equal else1 else2
| EEmpty, EEmpty -> true
| EErrorOnEmpty e1, EErrorOnEmpty e2 -> equal e1 e2
| ERaiseEmpty, ERaiseEmpty -> true
| ( ECatchEmpty { body = etry1; handler = ewith1 },
ECatchEmpty { body = etry2; handler = ewith2 } ) ->
equal etry1 etry2 && equal ewith1 ewith2
| ELocation l1, ELocation l2 ->
equal_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2)
| ( EStruct { name = s1; fields = fields1 },
@ -700,10 +682,9 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
Type.equal_list targs1 targs2 && Type.equal tret1 tret2 && obj1 == obj2
| ( ( EVar _ | EExternal _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _
| EAbs _ | EApp _ | EAppOp _ | EAssert _ | EFatalError _ | EDefault _
| EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ERaiseEmpty
| ECatchEmpty _ | ELocation _ | EStruct _ | EDStructAmend _
| EDStructAccess _ | EStructAccess _ | EInj _ | EMatch _ | EScopeCall _
| ECustom _ ),
| EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ELocation _
| EStruct _ | EDStructAmend _ | EDStructAccess _ | EStructAccess _
| EInj _ | EMatch _ | EScopeCall _ | ECustom _ ),
_ ) ->
false
@ -796,11 +777,6 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
| EEmpty, EEmpty -> 0
| EErrorOnEmpty e1, EErrorOnEmpty e2 ->
compare e1 e2
| ERaiseEmpty, ERaiseEmpty -> 0
| ECatchEmpty {body=etry1; handler=ewith1},
ECatchEmpty {body=etry2; handler=ewith2} ->
compare etry1 etry2 @@< fun () ->
compare ewith1 ewith2
| ECustom _, _ | _, ECustom _ ->
(* fixme: ideally this would be forbidden by typing *)
invalid_arg "Custom block comparison"
@ -827,9 +803,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
| EDefault _, _ -> -1 | _, EDefault _ -> 1
| EPureDefault _, _ -> -1 | _, EPureDefault _ -> 1
| EEmpty , _ -> -1 | _, EEmpty -> 1
| EErrorOnEmpty _, _ -> -1 | _, EErrorOnEmpty _ -> 1
| ERaiseEmpty, _ -> -1 | _, ERaiseEmpty -> 1
| ECatchEmpty _, _ -> . | _, ECatchEmpty _ -> .
| EErrorOnEmpty _, _ -> . | _, EErrorOnEmpty _ -> .
let rec free_vars : ('a, 't) gexpr -> ('a, 't) gexpr Var.Set.t = function
| EVar v, _ -> Var.Set.singleton v
@ -960,8 +934,6 @@ let rec size : type a. (a, 't) gexpr -> int =
(fun acc except -> acc + size except)
(1 + size just + size cons)
excepts
| ERaiseEmpty -> 1
| ECatchEmpty { body; handler } -> 1 + size body + size handler
| ELocation _ -> 1
| EStruct { fields; _ } ->
StructField.Map.fold (fun _ e acc -> acc + 1 + size e) fields 0

7
compiler/shared_ast/expr.mli
View File

@ -117,13 +117,6 @@ val eerroronempty :
'm mark ->
((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr
val ecatchempty :
('a, 'm) boxed_gexpr ->
('a, 'm) boxed_gexpr ->
'm mark ->
((< exceptions : yes ; .. > as 'a), 'm) boxed_gexpr
val eraiseempty : 'm mark -> (< exceptions : yes ; .. >, 'm) boxed_gexpr
val elocation : 'a glocation -> 'm mark -> ((< .. > as 'a), 'm) boxed_gexpr
val estruct :

75
compiler/shared_ast/interpreter.ml
View File

@ -460,15 +460,15 @@ let rec evaluate_operator
(* /S\ dark magic here. This relies both on internals of [Lcalc.to_ocaml] *and*
of the OCaml runtime *)
let rec runtime_to_val :
type d e.
type d.
(decl_ctx ->
((d, e, _) interpr_kind, 'm) gexpr ->
((d, e, _) interpr_kind, 'm) gexpr) ->
((d, _) interpr_kind, 'm) gexpr ->
((d, _) interpr_kind, 'm) gexpr) ->
decl_ctx ->
'm mark ->
typ ->
Obj.t ->
(((d, e, yes) interpr_kind as 'a), 'm) gexpr =
(((d, yes) interpr_kind as 'a), 'm) gexpr =
fun eval_expr ctx m ty o ->
let m = Expr.map_ty (fun _ -> ty) m in
match Mark.remove ty with
@ -539,13 +539,13 @@ let rec runtime_to_val :
| TAny -> assert false
and val_to_runtime :
type d e.
type d.
(decl_ctx ->
((d, e, _) interpr_kind, 'm) gexpr ->
((d, e, _) interpr_kind, 'm) gexpr) ->
((d, _) interpr_kind, 'm) gexpr ->
((d, _) interpr_kind, 'm) gexpr) ->
decl_ctx ->
typ ->
((d, e, _) interpr_kind, 'm) gexpr ->
((d, _) interpr_kind, 'm) gexpr ->
Obj.t =
fun eval_expr ctx ty v ->
match Mark.remove ty, Mark.remove v with
@ -631,11 +631,11 @@ and val_to_runtime :
Expr.format v
let rec evaluate_expr :
type d e.
type d.
decl_ctx ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
((d, yes) interpr_kind, 't) gexpr ->
((d, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
let m = Mark.get e in
let pos = Expr.mark_pos m in
@ -835,18 +835,14 @@ let rec evaluate_expr :
in
raise Runtime.(Error (Conflict, poslist)))
| EPureDefault e -> evaluate_expr ctx lang e
| ERaiseEmpty -> raise Runtime.Empty
| ECatchEmpty { body; handler } -> (
try evaluate_expr ctx lang body
with Runtime.Empty -> evaluate_expr ctx lang handler)
| _ -> .
and partially_evaluate_expr_for_assertion_failure_message :
type d e.
type d.
decl_ctx ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
((d, yes) interpr_kind, 't) gexpr ->
((d, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
(* Here we want to print an expression that explains why an assertion has
failed. Since assertions have type [bool] and are usually constructed with
@ -881,11 +877,11 @@ and partially_evaluate_expr_for_assertion_failure_message :
| _ -> evaluate_expr ctx lang e
let evaluate_expr_trace :
type d e.
type d.
decl_ctx ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
((d, yes) interpr_kind, 't) gexpr ->
((d, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
Fun.protect
(fun () -> evaluate_expr ctx lang e)
@ -897,11 +893,11 @@ let evaluate_expr_trace :
(Runtime.EventParser.parse_raw_events trace)] fais here, check why *))
let evaluate_expr_safe :
type d e.
type d.
decl_ctx ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
((d, yes) interpr_kind, 't) gexpr ->
((d, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
try evaluate_expr_trace ctx lang e
with Runtime.Error (err, rpos) ->
@ -913,9 +909,9 @@ let evaluate_expr_safe :
(* Typing shenanigan to add custom terms to the AST type. *)
let addcustom e =
let rec f :
type c d e.
((d, e, c) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr boxed = function
type c d.
((d, c) interpr_kind, 't) gexpr -> ((d, yes) interpr_kind, 't) gexpr boxed
= function
| (ECustom _, _) as e -> Expr.map ~f e
| EAppOp { op; tys; args }, m ->
Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) m
@ -923,8 +919,6 @@ let addcustom e =
| (EPureDefault _, _) as e -> Expr.map ~f e
| (EEmpty, _) as e -> Expr.map ~f e
| (EErrorOnEmpty _, _) as e -> Expr.map ~f e
| (ECatchEmpty _, _) as e -> Expr.map ~f e
| (ERaiseEmpty, _) as e -> Expr.map ~f e
| ( ( EAssert _ | EFatalError _ | ELit _ | EApp _ | EArray _ | EVar _
| EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _
| EInj _ | EStruct _ | EStructAccess _ | EMatch _ ),
@ -934,8 +928,8 @@ let addcustom e =
in
let open struct
external id :
(('d, 'e, 'c) interpr_kind, 't) gexpr ->
(('d, 'e, yes) interpr_kind, 't) gexpr = "%identity"
(('d, 'c) interpr_kind, 't) gexpr -> (('d, yes) interpr_kind, 't) gexpr
= "%identity"
end in
if false then Expr.unbox (f e)
(* We keep the implementation as a typing proof, but bypass the AST
@ -945,9 +939,9 @@ let addcustom e =
let delcustom e =
let rec f :
type c d e.
((d, e, c) interpr_kind, 't) gexpr ->
((d, e, no) interpr_kind, 't) gexpr boxed = function
type c d.
((d, c) interpr_kind, 't) gexpr -> ((d, no) interpr_kind, 't) gexpr boxed
= function
| ECustom _, _ -> invalid_arg "Custom term remaining in evaluated term"
| EAppOp { op; args; tys }, m ->
Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) m
@ -955,8 +949,6 @@ let delcustom e =
| (EPureDefault _, _) as e -> Expr.map ~f e
| (EEmpty, _) as e -> Expr.map ~f e
| (EErrorOnEmpty _, _) as e -> Expr.map ~f e
| (ECatchEmpty _, _) as e -> Expr.map ~f e
| (ERaiseEmpty, _) as e -> Expr.map ~f e
| ( ( EAssert _ | EFatalError _ | ELit _ | EApp _ | EArray _ | EVar _
| EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _
| EInj _ | EStruct _ | EStructAccess _ | EMatch _ ),
@ -987,22 +979,13 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(fun ty ->
match Mark.remove ty with
| TArrow (ty_in, (TOption _, _)) ->
(* Context args may return an option if avoid_exceptions is on *)
(* Context args should return an option *)
Expr.make_abs
(Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in)
(Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr
~name:Expr.option_enum mark_e
: (_, _) boxed_gexpr)
ty_in pos
| TArrow (ty_in, ty_out) ->
(* Or a default term (translated into a plain one if it is off) *)
(* Note: this might catch non-context args, but since the
compilation to lcalc strips the default around [ty_out] we can't
tell with just this info. *)
Expr.make_abs
(Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in)
(Expr.eraiseempty (Expr.with_ty mark_e ty_out))
ty_in (Expr.mark_pos mark_e)
| TTuple ((TArrow (ty_in, (TOption _, _)), _) :: _) ->
(* ... or a closure if closure conversion is enabled *)
Expr.make_tuple

12
compiler/shared_ast/interpreter.mli
View File

@ -21,7 +21,7 @@ open Catala_utils
open Definitions
val evaluate_operator :
((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
((((_, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
'a operator Mark.pos ->
'm mark ->
Global.backend_lang ->
@ -35,14 +35,14 @@ val evaluate_operator :
val evaluate_expr :
decl_ctx ->
Global.backend_lang ->
(('a, 'b, _) interpr_kind, 'm) gexpr ->
(('a, 'b, yes) interpr_kind, 'm) gexpr
(('a, _) interpr_kind, 'm) gexpr ->
(('a, yes) interpr_kind, 'm) gexpr
(** Evaluates an expression according to the semantics of the default calculus. *)
val interpret_program_dcalc :
(dcalc, 'm) gexpr program ->
ScopeName.t ->
(Uid.MarkedString.info * ((yes, no, yes) interpr_kind, 'm) gexpr) list
(Uid.MarkedString.info * ((yes, yes) interpr_kind, 'm) gexpr) list
(** Interprets a program. This function expects an expression typed as a
function whose argument are all thunked. The function is executed by
providing for each argument a thunked empty default. Returns a list of all
@ -51,14 +51,14 @@ val interpret_program_dcalc :
val interpret_program_lcalc :
(lcalc, 'm) gexpr program ->
ScopeName.t ->
(Uid.MarkedString.info * ((no, yes, yes) interpr_kind, 'm) gexpr) list
(Uid.MarkedString.info * ((no, yes) interpr_kind, 'm) gexpr) list
(** Interprets a program. This function expects an expression typed as a
function whose argument are all thunked. The function is executed by
providing for each argument a thunked empty default. Returns a list of all
the computed values for the scope variables of the executed scope. *)
val delcustom :
(('a, 'b, 'c) interpr_kind, 'm) gexpr -> (('a, 'b, no) interpr_kind, 'm) gexpr
(('a, 'b) interpr_kind, 'm) gexpr -> (('a, no) interpr_kind, 'm) gexpr
(** Runtime check that the term contains no custom terms (raises
[Invalid_argument] if that is the case *)

25
compiler/shared_ast/optimizations.ml
View File

@ -58,14 +58,14 @@ let all_match_cases_map_to_same_constructor cases n =
let binder_vars_used_at_most_once
(binder :
( (('a, 'b) dcalc_lcalc, ('a, 'b) dcalc_lcalc, 'm) base_gexpr,
(('a, 'b) dcalc_lcalc, 'm) gexpr )
( ('a dcalc_lcalc, 'a dcalc_lcalc, 'm) base_gexpr,
('a dcalc_lcalc, 'm) gexpr )
Bindlib.mbinder) : bool =
(* fast path: variables not used at all *)
(not (Array.exists Fun.id (Bindlib.mbinder_occurs binder)))
||
let vars, body = Bindlib.unmbind binder in
let rec vars_count (e : (('a, 'b) dcalc_lcalc, 'm) gexpr) : int array =
let rec vars_count (e : ('a dcalc_lcalc, 'm) gexpr) : int array =
match e with
| EVar v, _ ->
Array.map
@ -82,8 +82,8 @@ let binder_vars_used_at_most_once
let rec optimize_expr :
type a b.
(a, b, 'm) optimizations_ctx ->
((a, b) dcalc_lcalc, 'm) gexpr ->
((a, b) dcalc_lcalc, 'm) boxed_gexpr =
(a dcalc_lcalc, 'm) gexpr ->
(a dcalc_lcalc, 'm) boxed_gexpr =
fun ctx e ->
(* We proceed bottom-up, first apply on the subterms *)
let e = Expr.map ~f:(optimize_expr ctx) ~op:Fun.id e in
@ -92,7 +92,7 @@ let rec optimize_expr :
able to keep the inner position (see the division_by_zero test) *)
(* Then reduce the parent node (this is applied through Box.apply, therefore
delayed to unbinding time: no need to be concerned about reboxing) *)
let reduce (e : ((a, b) dcalc_lcalc, 'm) gexpr) =
let reduce (e : (a dcalc_lcalc, 'm) gexpr) =
(* Todo: improve the handling of eapp(log,elit) cases here, it obfuscates
the matches and the log calls are not preserved, which would be a good
property *)
@ -365,22 +365,15 @@ let rec optimize_expr :
el) ->
(* identity tuple reconstruction *)
Mark.remove e
| ECatchEmpty { body; handler } -> (
(* peephole exception catching reductions *)
match Mark.remove body, Mark.remove handler with
| ERaiseEmpty, _ -> Mark.remove handler
| _, ERaiseEmpty -> Mark.remove body
| _ -> ECatchEmpty { body; handler })
| e -> e
in
Expr.Box.app1 e reduce mark
let optimize_expr :
'm.
decl_ctx ->
(('a, 'b) dcalc_lcalc, 'm) gexpr ->
(('a, 'b) dcalc_lcalc, 'm) boxed_gexpr =
fun (decl_ctx : decl_ctx) (e : (('a, 'b) dcalc_lcalc, 'm) gexpr) ->
decl_ctx -> ('a dcalc_lcalc, 'm) gexpr -> ('a dcalc_lcalc, 'm) boxed_gexpr
=
fun (decl_ctx : decl_ctx) (e : ('a dcalc_lcalc, 'm) gexpr) ->
optimize_expr { decl_ctx } e
let optimize_program (p : 'm program) : 'm program =

7
compiler/shared_ast/optimizations.mli
View File

@ -21,13 +21,10 @@
open Definitions
val optimize_expr :
decl_ctx ->
(('a, 'b) dcalc_lcalc, 'm) gexpr ->
(('a, 'b) dcalc_lcalc, 'm) boxed_gexpr
decl_ctx -> ('a dcalc_lcalc, 'm) gexpr -> ('a dcalc_lcalc, 'm) boxed_gexpr
val optimize_program :
(('a, 'b) dcalc_lcalc, 'm) gexpr program ->
(('a, 'b) dcalc_lcalc, 'm) gexpr program
('a dcalc_lcalc, 'm) gexpr program -> ('a dcalc_lcalc, 'm) gexpr program
(** {1 Tests}*)

12
compiler/shared_ast/print.ml
View File

@ -424,8 +424,6 @@ module Precedence = struct
| EPureDefault _ -> Contained
| EEmpty -> Contained
| EErrorOnEmpty _ -> App
| ERaiseEmpty -> App
| ECatchEmpty _ -> App
| ECustom _ -> Contained
let needs_parens ~context ?(rhs = false) e =
@ -669,12 +667,6 @@ module ExprGen (C : EXPR_PARAM) = struct
| EFatalError err ->
Format.fprintf fmt "@[<hov 2>%a@ @{<red>%s@}@]" keyword "error"
(Runtime.error_to_string err)
| ECatchEmpty { body; handler } ->
Format.fprintf fmt
"@[<hv 0>@[<hov 2>%a@ %a@]@ @[<hov 2>%a@ %a ->@ %a@]@]" keyword "try"
expr body keyword "with" op_style "Empty" (rhs exprc) handler
| ERaiseEmpty ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" op_style "Empty"
| ELocation loc -> location fmt loc
| EDStructAccess { e; field; _ } ->
Format.fprintf fmt "@[<hv 2>%a%a@,%a%a%a@]" (lhs exprc) e punctuation
@ -1128,8 +1120,8 @@ module UserFacing = struct
| EExternal _ -> Format.pp_print_string ppf "<external>"
| EApp _ | EAppOp _ | EVar _ | EIfThenElse _ | EMatch _ | ETupleAccess _
| EStructAccess _ | EAssert _ | EFatalError _ | EDefault _ | EPureDefault _
| EErrorOnEmpty _ | ERaiseEmpty | ECatchEmpty _ | ELocation _ | EScopeCall _
| EDStructAmend _ | EDStructAccess _ | ECustom _ ->
| EErrorOnEmpty _ | ELocation _ | EScopeCall _ | EDStructAmend _
| EDStructAccess _ | ECustom _ ->
fallback ppf e
let expr :

5
compiler/shared_ast/typing.ml
View File

@ -760,11 +760,6 @@ and typecheck_expr_top_down :
args
in
Expr.escopecall ~scope ~args:args' mark
| A.ERaiseEmpty -> Expr.eraiseempty context_mark
| A.ECatchEmpty { body; handler } ->
let body' = typecheck_expr_top_down ctx env tau body in
let handler' = typecheck_expr_top_down ctx env tau handler in
Expr.ecatchempty body' handler' context_mark
| A.EVar v ->
let tau' =
match Env.get env v with