From 88f5e932c879e56aa15b6a10e73b70451b17bc19 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Mon, 24 Jun 2024 18:24:47 +0200 Subject: [PATCH] Remove RaiseEmpty and CatchEmpty from the AST --- compiler/lcalc/closure_conversion.ml | 5 +- compiler/lcalc/to_ocaml.ml | 4 -- compiler/scalc/from_lcalc.ml | 26 +--------- compiler/shared_ast/definitions.ml | 18 ++----- compiler/shared_ast/expr.ml | 40 +++----------- compiler/shared_ast/expr.mli | 7 --- compiler/shared_ast/interpreter.ml | 75 +++++++++++---------------- compiler/shared_ast/interpreter.mli | 12 ++--- compiler/shared_ast/optimizations.ml | 25 ++++----- compiler/shared_ast/optimizations.mli | 7 +-- compiler/shared_ast/print.ml | 12 +---- compiler/shared_ast/typing.ml | 5 -- 12 files changed, 60 insertions(+), 176 deletions(-) diff --git a/compiler/lcalc/closure_conversion.ml b/compiler/lcalc/closure_conversion.ml index c20a5881..7bce4552 100644 --- a/compiler/lcalc/closure_conversion.ml +++ b/compiler/lcalc/closure_conversion.ml @@ -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) | _ -> . diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index a4091dd7..a42c2d92 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -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 "@[@[try@ %a@]@ with Empty ->@]@ @[%a@]" - format_with_parens body format_with_parens handler | _ -> . let format_struct_embedding diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index f8331f34..2fe792bf 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -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 = diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 0d2e6bf9..83c00386 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -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; diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index a23abbf0..9f8a0d3f 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -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 diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index 292eff31..4ebf78ab 100644 --- a/compiler/shared_ast/expr.mli +++ b/compiler/shared_ast/expr.mli @@ -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 : diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index c6bac06c..88bfeb93 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -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 diff --git a/compiler/shared_ast/interpreter.mli b/compiler/shared_ast/interpreter.mli index f89c494e..cff47197 100644 --- a/compiler/shared_ast/interpreter.mli +++ b/compiler/shared_ast/interpreter.mli @@ -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 *) diff --git a/compiler/shared_ast/optimizations.ml b/compiler/shared_ast/optimizations.ml index c77a985c..3ad6f126 100644 --- a/compiler/shared_ast/optimizations.ml +++ b/compiler/shared_ast/optimizations.ml @@ -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 = diff --git a/compiler/shared_ast/optimizations.mli b/compiler/shared_ast/optimizations.mli index ea413388..b8f50357 100644 --- a/compiler/shared_ast/optimizations.mli +++ b/compiler/shared_ast/optimizations.mli @@ -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}*) diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index 3141b79d..f92b78a6 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -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 "@[%a@ @{%s@}@]" keyword "error" (Runtime.error_to_string err) - | ECatchEmpty { body; handler } -> - Format.fprintf fmt - "@[@[%a@ %a@]@ @[%a@ %a ->@ %a@]@]" keyword "try" - expr body keyword "with" op_style "Empty" (rhs exprc) handler - | ERaiseEmpty -> - Format.fprintf fmt "@[%a@ %a@]" keyword "raise" op_style "Empty" | ELocation loc -> location fmt loc | EDStructAccess { e; field; _ } -> Format.fprintf fmt "@[%a%a@,%a%a%a@]" (lhs exprc) e punctuation @@ -1128,8 +1120,8 @@ module UserFacing = struct | EExternal _ -> Format.pp_print_string ppf "" | 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 : diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 8302822b..6ac79c5b 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -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