From a64fdc8b1be70de43afe35ff788ba3240318daac Mon Sep 17 00:00:00 2001 From: Escherichia Date: Tue, 12 Mar 2024 15:02:17 +0100 Subject: WIP Beginning working on better errors: began replacing raise (Failure) and assert by craise and cassert. Does not compile yet, still need to propagate the meta variable where it's relevant --- compiler/Config.ml | 2 +- compiler/Errors.ml | 27 ++ compiler/InterpreterBorrows.ml | 487 +++++++++++++------------- compiler/InterpreterBorrowsCore.ml | 175 +++++----- compiler/InterpreterLoopsFixedPoint.ml | 85 ++--- compiler/InterpreterLoopsJoinCtxs.ml | 78 +++-- compiler/InterpreterLoopsMatchCtxs.ml | 5 +- compiler/InterpreterPaths.ml | 123 +++---- compiler/InterpreterProjectors.ml | 91 ++--- compiler/InterpreterStatements.ml | 266 +++++++------- compiler/Invariants.ml | 69 ++-- compiler/Main.ml | 4 +- compiler/SymbolicToPure.ml | 613 +++++++++++++++++---------------- compiler/Translate.ml | 82 ++--- compiler/dune | 1 + 15 files changed, 1076 insertions(+), 1032 deletions(-) create mode 100644 compiler/Errors.ml (limited to 'compiler') diff --git a/compiler/Config.ml b/compiler/Config.ml index 65aa7555..099cdc8b 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -318,7 +318,7 @@ let type_check_pure_code = ref false (** Shall we fail hard if we encounter an issue, or should we attempt to go as far as possible while leaving "holes" in the generated code? *) -let fail_hard = ref true +let fail_hard = ref false (** If true, add the type name as a prefix to the variant names. diff --git a/compiler/Errors.ml b/compiler/Errors.ml new file mode 100644 index 00000000..65c2cbb0 --- /dev/null +++ b/compiler/Errors.ml @@ -0,0 +1,27 @@ +let meta_to_string (span : Meta.span ) = + let file = match span.file with Virtual s | Local s -> s in + let loc_to_string (l : Meta.loc) : string = + string_of_int l.line ^ ":" ^ string_of_int l.col + in + "Source: '" ^ file ^ "', lines " ^ loc_to_string span.beg_loc ^ "-" + ^ loc_to_string span.end_loc + +let format_error_message (meta : Meta.meta) msg = + msg ^ ":" ^ meta_to_string meta.span + +exception CFailure of string + + +let error_list : (Meta.meta * string) list ref = ref [] +let save_error (meta : Meta.meta ) (msg : string) = error_list := (meta, msg)::(!error_list) + +let craise (meta : Meta.meta) (msg : string) = + if !Config.fail_hard then + raise (Failure (format_error_message meta msg)) + else + let () = save_error meta msg in + raise (CFailure msg) + +let cassert (b : bool) (meta : Meta.meta) (msg : string) = + if b then + craise meta msg \ No newline at end of file diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 17810705..ae251fbf 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -7,6 +7,7 @@ open TypesUtils open InterpreterUtils open InterpreterBorrowsCore open InterpreterProjectors +open Errors (** The local logger *) let log = Logging.borrows_log @@ -29,7 +30,7 @@ let log = Logging.borrows_log loans. This is used to merge borrows with abstractions, to compute loop fixed points for instance. *) -let end_borrow_get_borrow (allowed_abs : AbstractionId.id option) +let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id option) (allow_inner_loans : bool) (l : BorrowId.id) (ctx : eval_ctx) : ( eval_ctx * (AbstractionId.id option * g_borrow_content) option, priority_borrows_or_abs ) @@ -41,7 +42,7 @@ let end_borrow_get_borrow (allowed_abs : AbstractionId.id option) in let set_replaced_bc (abs_id : AbstractionId.id option) (bc : g_borrow_content) = - assert (Option.is_none !replaced_bc); + cassert (Option.is_none !replaced_bc) meta "TODO: error message"; replaced_bc := Some (abs_id, bc) in (* Raise an exception if: @@ -180,7 +181,7 @@ let end_borrow_get_borrow (allowed_abs : AbstractionId.id option) * Also note that, as we are moving the borrowed value inside the * abstraction (and not really giving the value back to the context) * we do not insert {!AEndedMutBorrow} but rather {!ABottom} *) - raise (Failure "Unimplemented") + craise meta "Unimplemented" (* ABottom *)) else (* Update the outer borrows before diving into the child avalue *) @@ -223,8 +224,8 @@ let end_borrow_get_borrow (allowed_abs : AbstractionId.id option) method! visit_abs outer abs = (* Update the outer abs *) let outer_abs, outer_borrows = outer in - assert (Option.is_none outer_abs); - assert (Option.is_none outer_borrows); + cassert (Option.is_none outer_abs) meta "TODO: error message"; + cassert (Option.is_none outer_borrows) meta "TODO: error message"; let outer = (Some abs.abs_id, None) in super#visit_abs outer abs end @@ -244,11 +245,11 @@ let end_borrow_get_borrow (allowed_abs : AbstractionId.id option) give the value back. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) +let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv : typed_value) (ctx : eval_ctx) : eval_ctx = (* Sanity check *) - assert (not (loans_in_value nv)); - assert (not (bottom_in_value ctx.ended_regions nv)); + cassert (not (loans_in_value nv)) meta "TODO: error message"; + cassert (not (bottom_in_value ctx.ended_regions nv)) meta "TODO: error message"; (* Debug *) log#ldebug (lazy @@ -258,7 +259,7 @@ let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - assert (not !replaced); + cassert (not !replaced) meta "Exactly one loan should have been updated"; replaced := true in (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) @@ -300,7 +301,7 @@ let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) ("give_back_value: improper type:\n- expected: " ^ ty_to_string ctx ty ^ "\n- received: " ^ ty_to_string ctx nv.ty); - raise (Failure "Value given back doesn't have the proper type")); + craise meta "Value given back doesn't have the proper type"); (* Replace *) set_replaced (); nv.value) @@ -345,7 +346,7 @@ let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) ABorrow (AEndedIgnoredMutBorrow { given_back; child; given_back_meta }) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" else (* Continue exploring *) ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) @@ -360,7 +361,7 @@ let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) (* Preparing a bit *) let regions, ancestors_regions = match opt_abs with - | None -> raise (Failure "Unreachable") + | None -> craise meta "Unreachable" | Some abs -> (abs.regions, abs.ancestors_regions) in (* Rk.: there is a small issue with the types of the aloan values. @@ -426,7 +427,7 @@ let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) (* We remember in which abstraction we are before diving - * this is necessary for projecting values: we need to know * over which regions to project *) - assert (Option.is_none opt_abs); + cassert (Option.is_none opt_abs) meta "TODO: error message"; super#visit_EAbs (Some abs) abs end in @@ -434,16 +435,16 @@ let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - assert !replaced; + cassert !replaced meta "Only one loan should have been given back"; (* Apply the reborrows *) apply_registered_reborrows ctx (** Give back a *modified* symbolic value. *) -let give_back_symbolic_value (_config : config) (proj_regions : RegionId.Set.t) +let give_back_symbolic_value (meta : Meta.meta) (_config : config) (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) - assert (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty); + cassert (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) meta "TODO: error message"; (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in (* Substitution function, to replace the borrow projectors over symbolic values *) @@ -465,11 +466,11 @@ let give_back_symbolic_value (_config : config) (proj_regions : RegionId.Set.t) type [T]! We thus *mustn't* introduce a projector here. *) (* AProjBorrows (nsv, sv.sv_ty) *) - raise (Failure "TODO") + craise meta "TODO: error message" in AProjLoans (sv, (mv, child_proj) :: local_given_back) in - update_intersecting_aproj_loans proj_regions proj_ty sv subst ctx + update_intersecting_aproj_loans meta proj_regions proj_ty sv subst ctx (** Auxiliary function to end borrows. See {!give_back}. @@ -484,12 +485,12 @@ let give_back_symbolic_value (_config : config) (proj_regions : RegionId.Set.t) end abstraction when ending this abstraction. When doing this, we need to convert the {!avalue} to a {!type:value} by introducing the proper symbolic values. *) -let give_back_avalue_to_same_abstraction (_config : config) (bid : BorrowId.id) +let give_back_avalue_to_same_abstraction (meta : Meta.meta) (_config : config) (bid : BorrowId.id) (nv : typed_avalue) (nsv : typed_value) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - assert (not !replaced); + cassert (not !replaced) meta "Only one loan should have been updated"; replaced := true in let obj = @@ -532,7 +533,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (bid : BorrowId.id) ("give_back_avalue_to_same_abstraction: improper type:\n\ - expected: " ^ ty_to_string ctx ty ^ "\n- received: " ^ ty_to_string ctx nv.ty); - raise (Failure "Value given back doesn't have the proper type")); + craise meta "Value given back doesn't have the proper type"); (* This is the loan we are looking for: apply the projection to * the value we give back and replaced this mutable loan with * an ended loan *) @@ -558,7 +559,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (bid : BorrowId.id) * we don't register the fact that we inserted the value somewhere * (i.e., we don't call {!set_replaced}) *) (* Sanity check *) - assert (nv.ty = ty); + cassert (nv.ty = ty) meta "TODO: error message"; ALoan (AEndedIgnoredMutLoan { given_back = nv; child; given_back_meta = nsv })) @@ -574,7 +575,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (bid : BorrowId.id) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - assert !replaced; + cassert !replaced meta "Only one loan should be given back"; (* Return *) ctx @@ -587,11 +588,11 @@ let give_back_avalue_to_same_abstraction (_config : config) (bid : BorrowId.id) we update. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_shared _config (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = +let give_back_shared (meta : Meta.meta) _config (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - assert (not !replaced); + cassert (not !replaced) meta "Only one loan should be updated"; replaced := true in let obj = @@ -656,7 +657,7 @@ let give_back_shared _config (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - assert !replaced; + cassert !replaced meta "Exactly one loan should be given back"; (* Return *) ctx @@ -665,12 +666,12 @@ let give_back_shared _config (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = to an environment by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -let reborrow_shared (original_bid : BorrowId.id) (new_bid : BorrowId.id) +let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (new_bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = (* Keep track of changes *) let r = ref false in let set_ref () = - assert (not !r); + cassert (not !r) meta "TODO: error message"; r := true in @@ -700,7 +701,7 @@ let reborrow_shared (original_bid : BorrowId.id) (new_bid : BorrowId.id) let env = obj#visit_env () ctx.env in (* Check that we reborrowed once *) - assert !r; + cassert !r meta "Not reborrowed once"; { ctx with env } (** Convert an {!type:avalue} to a {!type:value}. @@ -738,7 +739,7 @@ let convert_avalue_to_given_back_value (av : typed_avalue) : symbolic_value = borrows. This kind of internal reshuffling. should be similar to ending abstractions (it is tantamount to ending *sub*-abstractions). *) -let give_back (config : config) (l : BorrowId.id) (bc : g_borrow_content) +let give_back (meta : Meta.meta) (config : config) (l : BorrowId.id) (bc : g_borrow_content) (ctx : eval_ctx) : eval_ctx = (* Debug *) log#ldebug @@ -757,24 +758,24 @@ let give_back (config : config) (l : BorrowId.id) (bc : g_borrow_content) match bc with | Concrete (VMutBorrow (l', tv)) -> (* Sanity check *) - assert (l' = l); - assert (not (loans_in_value tv)); + cassert (l' = l) meta "TODO: error message"; + cassert (not (loans_in_value tv)) meta "TODO: error message"; (* Check that the corresponding loan is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The corresponding loan should be somewhere"; (* Update the context *) - give_back_value config l tv ctx + give_back_value meta config l tv ctx | Concrete (VSharedBorrow l' | VReservedMutBorrow l') -> (* Sanity check *) - assert (l' = l); + cassert (l' = l) meta "TODO: error message"; (* Check that the borrow is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The borrow should be somewhere"; (* Update the context *) - give_back_shared config l ctx + give_back_shared meta config l ctx | Abstract (AMutBorrow (l', av)) -> (* Sanity check *) - assert (l' = l); + cassert (l' = l) meta "TODO: error message"; (* Check that the corresponding loan is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The corresponding loan should be somewhere"; (* Convert the avalue to a (fresh symbolic) value. Rem.: we shouldn't do this here. We should do this in a function @@ -782,27 +783,27 @@ let give_back (config : config) (l : BorrowId.id) (bc : g_borrow_content) *) let sv = convert_avalue_to_given_back_value av in (* Update the context *) - give_back_avalue_to_same_abstraction config l av + give_back_avalue_to_same_abstraction meta config l av (mk_typed_value_from_symbolic_value sv) ctx | Abstract (ASharedBorrow l') -> (* Sanity check *) - assert (l' = l); + cassert (l' = l) meta "TODO: error message"; (* Check that the borrow is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The borrow should be somewhere"; (* Update the context *) - give_back_shared config l ctx + give_back_shared meta config l ctx | Abstract (AProjSharedBorrow asb) -> (* Sanity check *) - assert (borrow_in_asb l asb); + cassert (borrow_in_asb l asb) meta "TODO: error message"; (* Update the context *) - give_back_shared config l ctx + give_back_shared meta config l ctx | Abstract ( AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedSharedBorrow ) -> - raise (Failure "Unreachable") + craise meta "Unreachable" -let check_borrow_disappeared (fun_name : string) (l : BorrowId.id) +let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowId.id) (ctx0 : eval_ctx) : cm_fun = let check_disappeared (ctx : eval_ctx) : unit = let _ = @@ -815,9 +816,9 @@ let check_borrow_disappeared (fun_name : string) (l : BorrowId.id) ^ ": borrow didn't disappear:\n- original context:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx)); - raise (Failure "Borrow not eliminated") + craise meta "Borrow not eliminated" in - match lookup_loan_opt ek_all l ctx with + match lookup_loan_opt meta ek_all l ctx with | None -> () (* Ok *) | Some _ -> log#lerror @@ -826,7 +827,7 @@ let check_borrow_disappeared (fun_name : string) (l : BorrowId.id) ^ ": loan didn't disappear:\n- original context:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx)); - raise (Failure "Loan not eliminated") + craise meta "Loan not eliminated" in unit_to_cm_fun check_disappeared @@ -851,7 +852,7 @@ let check_borrow_disappeared (fun_name : string) (l : BorrowId.id) perform anything smart and is trusted, and another function for the book-keeping. *) -let rec end_borrow_aux (config : config) (chain : borrow_or_abs_ids) +let rec end_borrow_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) (allowed_abs : AbstractionId.id option) (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) @@ -867,10 +868,10 @@ let rec end_borrow_aux (config : config) (chain : borrow_or_abs_ids) (* Utility function for the sanity checks: check that the borrow disappeared * from the context *) let ctx0 = ctx in - let cf_check : cm_fun = check_borrow_disappeared "end borrow" l ctx0 in + let cf_check : cm_fun = check_borrow_disappeared meta "end borrow" l ctx0 in (* Start by ending the borrow itself (we lookup it up and replace it with [Bottom] *) let allow_inner_loans = false in - match end_borrow_get_borrow allowed_abs allow_inner_loans l ctx with + match end_borrow_get_borrow meta allowed_abs allow_inner_loans l ctx with (* Two cases: - error: we found outer borrows (the borrow is inside a borrowed value) or inner loans (the borrow contains loans) @@ -899,29 +900,29 @@ let rec end_borrow_aux (config : config) (chain : borrow_or_abs_ids) * inside another borrow *) let allowed_abs' = None in (* End the outer borrows *) - let cc = end_borrows_aux config chain allowed_abs' bids in + let cc = end_borrows_aux meta config chain allowed_abs' bids in (* Retry to end the borrow *) - let cc = comp cc (end_borrow_aux config chain0 allowed_abs l) in + let cc = comp cc (end_borrow_aux meta config chain0 allowed_abs l) in (* Check and apply *) comp cc cf_check cf ctx | OuterBorrows (Borrow bid) | InnerLoans (Borrow bid) -> let allowed_abs' = None in (* End the outer borrow *) - let cc = end_borrow_aux config chain allowed_abs' bid in + let cc = end_borrow_aux meta config chain allowed_abs' bid in (* Retry to end the borrow *) - let cc = comp cc (end_borrow_aux config chain0 allowed_abs l) in + let cc = comp cc (end_borrow_aux meta config chain0 allowed_abs l) in (* Check and apply *) comp cc cf_check cf ctx | OuterAbs abs_id -> (* The borrow is inside an abstraction: end the whole abstraction *) - let cf_end_abs = end_abstraction_aux config chain abs_id in + let cf_end_abs = end_abstraction_aux meta config chain abs_id in (* Compose with a sanity check *) comp cf_end_abs cf_check cf ctx) | Ok (ctx, None) -> log#ldebug (lazy "End borrow: borrow not found"); (* It is possible that we can't find a borrow in symbolic mode (ending * an abstraction may end several borrows at once *) - assert (config.mode = SymbolicMode); + cassert (config.mode = SymbolicMode) meta "Borrow should be in symbolic mode"; (* Do a sanity check and continue *) cf_check cf ctx (* We found a borrow and replaced it with [Bottom]: give it back (i.e., update @@ -930,10 +931,10 @@ let rec end_borrow_aux (config : config) (chain : borrow_or_abs_ids) (* Sanity check: the borrowed value shouldn't contain loans *) (match bc with | Concrete (VMutBorrow (_, bv)) -> - assert (Option.is_none (get_first_loan_in_value bv)) + cassert (Option.is_none (get_first_loan_in_value bv)) meta "Borrowed value shouldn't contain loans" | _ -> ()); (* Give back the value *) - let ctx = give_back config l bc ctx in + let ctx = give_back meta config l bc ctx in (* Do a sanity check and continue *) let cc = cf_check in (* Save a snapshot of the environment for the name generation *) @@ -941,7 +942,7 @@ let rec end_borrow_aux (config : config) (chain : borrow_or_abs_ids) (* Compose *) cc cf ctx -and end_borrows_aux (config : config) (chain : borrow_or_abs_ids) +and end_borrows_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) (allowed_abs : AbstractionId.id option) (lset : BorrowId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the borrow ids, @@ -949,10 +950,10 @@ and end_borrows_aux (config : config) (chain : borrow_or_abs_ids) * a matter of taste, and may make debugging easier *) let ids = BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in List.fold_left - (fun cf id -> end_borrow_aux config chain allowed_abs id cf) + (fun cf id -> end_borrow_aux meta config chain allowed_abs id cf) cf ids -and end_abstraction_aux (config : config) (chain : borrow_or_abs_ids) +and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) @@ -983,14 +984,14 @@ and end_abstraction_aux (config : config) (chain : borrow_or_abs_ids) (* Check that we can end the abstraction *) if abs.can_end then () else - raise - (Failure + craise + meta ("Can't end abstraction " ^ AbstractionId.to_string abs.abs_id - ^ " as it is set as non-endable")); + ^ " as it is set as non-endable"); (* End the parent abstractions first *) - let cc = end_abstractions_aux config chain abs.parents in + let cc = end_abstractions_aux meta config chain abs.parents in let cc = comp_unit cc (fun ctx -> log#ldebug @@ -1002,7 +1003,7 @@ and end_abstraction_aux (config : config) (chain : borrow_or_abs_ids) in (* End the loans inside the abstraction *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in + let cc = comp cc (end_abstraction_loans meta config chain abs_id) in let cc = comp_unit cc (fun ctx -> log#ldebug @@ -1013,7 +1014,7 @@ and end_abstraction_aux (config : config) (chain : borrow_or_abs_ids) in (* End the abstraction itself by redistributing the borrows it contains *) - let cc = comp cc (end_abstraction_borrows config chain abs_id) in + let cc = comp cc (end_abstraction_borrows meta config chain abs_id) in (* End the regions owned by the abstraction - note that we don't need to * relookup the abstraction: the set of regions in an abstraction never @@ -1043,7 +1044,7 @@ and end_abstraction_aux (config : config) (chain : borrow_or_abs_ids) in (* Sanity check: ending an abstraction must preserve the invariants *) - let cc = comp cc Invariants.cf_check_invariants in + let cc = comp cc (Invariants.cf_check_invariants meta) in (* Save a snapshot of the environment for the name generation *) let cc = comp cc SynthesizeSymbolic.cf_save_snapshot in @@ -1051,7 +1052,7 @@ and end_abstraction_aux (config : config) (chain : borrow_or_abs_ids) (* Apply the continuation *) cc cf ctx -and end_abstractions_aux (config : config) (chain : borrow_or_abs_ids) +and end_abstractions_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) (abs_ids : AbstractionId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the abstraction ids, @@ -1059,10 +1060,10 @@ and end_abstractions_aux (config : config) (chain : borrow_or_abs_ids) * a matter of taste, and may make debugging easier *) let abs_ids = AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in List.fold_left - (fun cf id -> end_abstraction_aux config chain id cf) + (fun cf id -> end_abstraction_aux meta config chain id cf) cf abs_ids -and end_abstraction_loans (config : config) (chain : borrow_or_abs_ids) +and end_abstraction_loans (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Lookup the abstraction *) @@ -1071,7 +1072,7 @@ and end_abstraction_loans (config : config) (chain : borrow_or_abs_ids) * * We ignore the "ignored mut/shared loans": as we should have already ended * the parent abstractions, they necessarily come from children. *) - let opt_loan = get_first_non_ignored_aloan_in_abstraction abs in + let opt_loan = get_first_non_ignored_aloan_in_abstraction meta abs in match opt_loan with | None -> (* No loans: nothing to update *) @@ -1080,23 +1081,23 @@ and end_abstraction_loans (config : config) (chain : borrow_or_abs_ids) (* There are loans: end the corresponding borrows, then recheck *) let cc : cm_fun = match bids with - | Borrow bid -> end_borrow_aux config chain None bid - | Borrows bids -> end_borrows_aux config chain None bids + | Borrow bid -> end_borrow_aux meta config chain None bid + | Borrows bids -> end_borrows_aux meta config chain None bids in (* Reexplore, looking for loans *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in + let cc = comp cc (end_abstraction_loans meta config chain abs_id) in (* Continue *) cc cf ctx | Some (SymbolicValue sv) -> (* There is a proj_loans over a symbolic value: end the proj_borrows * which intersect this proj_loans, then end the proj_loans itself *) - let cc = end_proj_loans_symbolic config chain abs_id abs.regions sv in + let cc = end_proj_loans_symbolic meta config chain abs_id abs.regions sv in (* Reexplore, looking for loans *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in + let cc = comp cc (end_abstraction_loans meta config chain abs_id) in (* Continue *) cc cf ctx -and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) +and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> log#ldebug @@ -1147,7 +1148,7 @@ and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) method! visit_aproj env sproj = (match sproj with - | AProjLoans _ -> raise (Failure "Unexpected") + | AProjLoans _ -> craise meta "Unexpected" | AProjBorrows (sv, proj_ty) -> raise (FoundAProjBorrows (sv, proj_ty)) | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj env sproj @@ -1156,7 +1157,7 @@ and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) method! visit_borrow_content _ bc = match bc with | VSharedBorrow _ | VMutBorrow (_, _) -> raise (FoundBorrowContent bc) - | VReservedMutBorrow _ -> raise (Failure "Unreachable") + | VReservedMutBorrow _ -> craise meta "Unreachable" end in (* Lookup the abstraction *) @@ -1181,16 +1182,16 @@ and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) (* Replace the mut borrow to register the fact that we ended * it and store with it the freshly generated given back value *) let ended_borrow = ABorrow (AEndedMutBorrow (sv, av)) in - let ctx = update_aborrow ek_all bid ended_borrow ctx in + let ctx = update_aborrow meta ek_all bid ended_borrow ctx in (* Give the value back *) let sv = mk_typed_value_from_symbolic_value sv in - give_back_value config bid sv ctx + give_back_value meta config bid sv ctx | ASharedBorrow bid -> (* Replace the shared borrow to account for the fact it ended *) let ended_borrow = ABorrow AEndedSharedBorrow in - let ctx = update_aborrow ek_all bid ended_borrow ctx in + let ctx = update_aborrow meta ek_all bid ended_borrow ctx in (* Give back *) - give_back_shared config bid ctx + give_back_shared meta config bid ctx | AProjSharedBorrow asb -> (* Retrieve the borrow ids *) let bids = @@ -1205,21 +1206,21 @@ and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) * can use to identify the whole set *) let repr_bid = List.hd bids in (* Replace the shared borrow with Bottom *) - let ctx = update_aborrow ek_all repr_bid ABottom ctx in + let ctx = update_aborrow meta ek_all repr_bid ABottom ctx in (* Give back the shared borrows *) let ctx = List.fold_left - (fun ctx bid -> give_back_shared config bid ctx) + (fun ctx bid -> give_back_shared meta config bid ctx) ctx bids in (* Continue *) ctx | AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedSharedBorrow -> - raise (Failure "Unexpected") + craise meta "Unexpected" in (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx + end_abstraction_borrows meta config chain abs_id cf ctx (* There are symbolic borrows: end them, then reexplore *) | FoundAProjBorrows (sv, proj_ty) -> log#ldebug @@ -1230,13 +1231,13 @@ and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) let nsv = mk_fresh_symbolic_value proj_ty in (* Replace the proj_borrows - there should be exactly one *) let ended_borrow = AEndedProjBorrows nsv in - let ctx = update_aproj_borrows abs.abs_id sv ended_borrow ctx in + let ctx = update_aproj_borrows meta abs.abs_id sv ended_borrow ctx in (* Give back the symbolic value *) let ctx = - give_back_symbolic_value config abs.regions proj_ty sv nsv ctx + give_back_symbolic_value meta config abs.regions proj_ty sv nsv ctx in (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx + end_abstraction_borrows meta config chain abs_id cf ctx (* There are concrete (i.e., not symbolic) borrows in shared values: end them, then reexplore *) | FoundBorrowContent bc -> log#ldebug @@ -1249,27 +1250,27 @@ and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) (* Replace the shared borrow with bottom *) let allow_inner_loans = false in match - end_borrow_get_borrow (Some abs_id) allow_inner_loans bid ctx + end_borrow_get_borrow meta (Some abs_id) allow_inner_loans bid ctx with - | Error _ -> raise (Failure "Unreachable") + | Error _ -> craise meta "Unreachable" | Ok (ctx, _) -> (* Give back *) - give_back_shared config bid ctx) + give_back_shared meta config bid ctx) | VMutBorrow (bid, v) -> ( (* Replace the mut borrow with bottom *) let allow_inner_loans = false in match - end_borrow_get_borrow (Some abs_id) allow_inner_loans bid ctx + end_borrow_get_borrow meta (Some abs_id) allow_inner_loans bid ctx with - | Error _ -> raise (Failure "Unreachable") + | Error _ -> craise meta "Unreachable" | Ok (ctx, _) -> (* Give the value back - note that the mut borrow was below a * shared borrow: the value is thus unchanged *) - give_back_value config bid v ctx) - | VReservedMutBorrow _ -> raise (Failure "Unreachable") + give_back_value meta config bid v ctx) + | VReservedMutBorrow _ -> craise meta "Unreachable" in (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx + end_abstraction_borrows meta config chain abs_id cf ctx (** Remove an abstraction from the context, as well as all its references *) and end_abstraction_remove_from_context (_config : config) @@ -1296,12 +1297,12 @@ and end_abstraction_remove_from_context (_config : config) intersecting proj_borrows, either in the concrete context or in an abstraction *) -and end_proj_loans_symbolic (config : config) (chain : borrow_or_abs_ids) +and end_proj_loans_symbolic (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) (regions : RegionId.Set.t) (sv : symbolic_value) : cm_fun = fun cf ctx -> (* Small helpers for sanity checks *) - let check ctx = no_aproj_over_symbolic_in_context sv ctx in + let check ctx = no_aproj_over_symbolic_in_context meta sv ctx in let cf_check (cf : m_fun) : m_fun = fun ctx -> check ctx; @@ -1309,13 +1310,13 @@ and end_proj_loans_symbolic (config : config) (chain : borrow_or_abs_ids) in (* Find the first proj_borrows which intersects the proj_loans *) let explore_shared = true in - match lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx with + match lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx with | None -> (* We couldn't find any in the context: it means that the symbolic value * is in the concrete environment (or that we dropped it, in which case * it is completely absent). We thus simply need to replace the loans * projector with an ended projector. *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in + let ctx = update_aproj_loans_to_ended meta abs_id sv ctx in (* Sanity check *) check ctx; (* Continue *) @@ -1359,15 +1360,15 @@ and end_proj_loans_symbolic (config : config) (chain : borrow_or_abs_ids) AbstractionId.Set.empty abs_ids in (* End the abstractions and continue *) - end_abstractions_aux config chain abs_ids cf ctx + end_abstractions_aux meta config chain abs_ids cf ctx in (* End the internal borrows projectors and the loans projector *) let cf_end_internal : cm_fun = fun cf ctx -> (* All the proj_borrows are owned: simply erase them *) - let ctx = remove_intersecting_aproj_borrows_shared regions sv ctx in + let ctx = remove_intersecting_aproj_borrows_shared meta regions sv ctx in (* End the loan itself *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in + let ctx = update_aproj_loans_to_ended meta abs_id sv ctx in (* Sanity check *) check ctx; (* Continue *) @@ -1399,48 +1400,48 @@ and end_proj_loans_symbolic (config : config) (chain : borrow_or_abs_ids) *) (* End the projector of borrows - TODO: not completely sure what to * replace it with... Maybe we should introduce an ABottomProj? *) - let ctx = update_aproj_borrows abs_id sv AIgnoredProjBorrows ctx in + let ctx = update_aproj_borrows meta abs_id sv AIgnoredProjBorrows ctx in (* Sanity check: no other occurrence of an intersecting projector of borrows *) - assert ( + cassert ( Option.is_none - (lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx)); + (lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx)) meta "no other occurrence of an intersecting projector of borrows"; (* End the projector of loans *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in + let ctx = update_aproj_loans_to_ended meta abs_id sv ctx in (* Sanity check *) check ctx; (* Continue *) cf ctx) else (* The borrows proj comes from a different abstraction: end it. *) - let cc = end_abstraction_aux config chain abs_id' in + let cc = end_abstraction_aux meta config chain abs_id' in (* Retry ending the projector of loans *) let cc = - comp cc (end_proj_loans_symbolic config chain abs_id regions sv) + comp cc (end_proj_loans_symbolic meta config chain abs_id regions sv) in (* Sanity check *) let cc = comp cc cf_check in (* Continue *) cc cf ctx -let end_borrow config : BorrowId.id -> cm_fun = end_borrow_aux config [] None +let end_borrow (meta : Meta.meta ) config : BorrowId.id -> cm_fun = end_borrow_aux meta config [] None -let end_borrows config : BorrowId.Set.t -> cm_fun = - end_borrows_aux config [] None +let end_borrows (meta : Meta.meta ) config : BorrowId.Set.t -> cm_fun = + end_borrows_aux meta config [] None -let end_abstraction config = end_abstraction_aux config [] -let end_abstractions config = end_abstractions_aux config [] +let end_abstraction meta config = end_abstraction_aux meta config [] +let end_abstractions meta config = end_abstractions_aux meta config [] -let end_borrow_no_synth config id ctx = - get_cf_ctx_no_synth (end_borrow config id) ctx +let end_borrow_no_synth meta config id ctx = + get_cf_ctx_no_synth (end_borrow meta config id) ctx -let end_borrows_no_synth config ids ctx = - get_cf_ctx_no_synth (end_borrows config ids) ctx +let end_borrows_no_synth meta config ids ctx = + get_cf_ctx_no_synth (end_borrows meta config ids) ctx -let end_abstraction_no_synth config id ctx = - get_cf_ctx_no_synth (end_abstraction config id) ctx +let end_abstraction_no_synth meta config id ctx = + get_cf_ctx_no_synth (end_abstraction meta config id) ctx -let end_abstractions_no_synth config ids ctx = - get_cf_ctx_no_synth (end_abstractions config ids) ctx +let end_abstractions_no_synth meta config ids ctx = + get_cf_ctx_no_synth (end_abstractions meta config ids) ctx (** Helper function: see {!activate_reserved_mut_borrow}. @@ -1458,7 +1459,7 @@ let end_abstractions_no_synth config ids ctx = The loan to update mustn't be a borrowed value. *) -let promote_shared_loan_to_mut_loan (l : BorrowId.id) +let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) @@ -1473,38 +1474,38 @@ let promote_shared_loan_to_mut_loan (l : BorrowId.id) let ek = { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } in - match lookup_loan ek l ctx with + match lookup_loan meta ek l ctx with | _, Concrete (VMutLoan _) -> - raise (Failure "Expected a shared loan, found a mut loan") + craise meta "Expected a shared loan, found a mut loan" | _, Concrete (VSharedLoan (bids, sv)) -> (* Check that there is only one borrow id (l) and update the loan *) - assert (BorrowId.Set.mem l bids && BorrowId.Set.cardinal bids = 1); + cassert (BorrowId.Set.mem l bids && BorrowId.Set.cardinal bids = 1) meta "There should only be one borrow id"; (* We need to check that there aren't any loans in the value: we should have gotten rid of those already, but it is better to do a sanity check. *) - assert (not (loans_in_value sv)); + cassert (not (loans_in_value sv)) meta "There shouldn't be any loans in the value"; (* Check there isn't {!Bottom} (this is actually an invariant *) - assert (not (bottom_in_value ctx.ended_regions sv)); + cassert (not (bottom_in_value ctx.ended_regions sv)) meta "There shouldn't be a !Bottom"; (* Check there aren't reserved borrows *) - assert (not (reserved_in_value sv)); + cassert (not (reserved_in_value sv)) meta "There shouldn't have reserved borrows"; (* Update the loan content *) - let ctx = update_loan ek l (VMutLoan l) ctx in + let ctx = update_loan meta ek l (VMutLoan l) ctx in (* Continue *) cf sv ctx | _, Abstract _ -> (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) - raise - (Failure + craise + meta "Can't promote a shared loan to a mutable loan if the loan is \ - inside an abstraction") + inside an abstraction" (** Helper function: see {!activate_reserved_mut_borrow}. This function updates a shared borrow to a mutable borrow (and that is all: it doesn't touch the corresponding loan). *) -let replace_reserved_borrow_with_mut_borrow (l : BorrowId.id) (cf : m_fun) +let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) (cf : m_fun) (borrowed_value : typed_value) : m_fun = fun ctx -> (* Lookup the reserved borrow - note that we don't go inside borrows/loans: @@ -1514,32 +1515,32 @@ let replace_reserved_borrow_with_mut_borrow (l : BorrowId.id) (cf : m_fun) { enter_shared_loans = false; enter_mut_borrows = false; enter_abs = false } in let ctx = - match lookup_borrow ek l ctx with + match lookup_borrow meta ek l ctx with | Concrete (VSharedBorrow _ | VMutBorrow (_, _)) -> - raise (Failure "Expected a reserved mutable borrow") + craise meta "Expected a reserved mutable borrow" | Concrete (VReservedMutBorrow _) -> (* Update it *) - update_borrow ek l (VMutBorrow (l, borrowed_value)) ctx + update_borrow meta ek l (VMutBorrow (l, borrowed_value)) ctx | Abstract _ -> (* This can't happen for sure *) - raise - (Failure + craise + meta "Can't promote a shared borrow to a mutable borrow if the borrow \ - is inside an abstraction") + is inside an abstraction" in (* Continue *) cf ctx (** Promote a reserved mut borrow to a mut borrow. *) -let rec promote_reserved_mut_borrow (config : config) (l : BorrowId.id) : cm_fun +let rec promote_reserved_mut_borrow (meta : Meta.meta) (config : config) (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Lookup the value *) let ek = { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } in - match lookup_loan ek l ctx with - | _, Concrete (VMutLoan _) -> raise (Failure "Unreachable") + match lookup_loan meta ek l ctx with + | _, Concrete (VMutLoan _) -> craise meta "Unreachable" | _, Concrete (VSharedLoan (bids, sv)) -> ( (* If there are loans inside the value, end them. Note that there can't be reserved borrows inside the value. @@ -1549,11 +1550,11 @@ let rec promote_reserved_mut_borrow (config : config) (l : BorrowId.id) : cm_fun (* End the loans *) let cc = match lc with - | VSharedLoan (bids, _) -> end_borrows config bids - | VMutLoan bid -> end_borrow config bid + | VSharedLoan (bids, _) -> end_borrows meta config bids + | VMutLoan bid -> end_borrow meta config bid in (* Recursive call *) - let cc = comp cc (promote_reserved_mut_borrow config l) in + let cc = comp cc (promote_reserved_mut_borrow meta config l) in (* Continue *) cc cf ctx | None -> @@ -1563,36 +1564,36 @@ let rec promote_reserved_mut_borrow (config : config) (l : BorrowId.id) : cm_fun (lazy ("activate_reserved_mut_borrow: resulting value:\n" ^ typed_value_to_string ctx sv)); - assert (not (loans_in_value sv)); - assert (not (bottom_in_value ctx.ended_regions sv)); - assert (not (reserved_in_value sv)); + cassert (not (loans_in_value sv)) meta "TODO: error message"; + cassert (not (bottom_in_value ctx.ended_regions sv)) meta "TODO: error message"; + cassert (not (reserved_in_value sv)) meta "TODO: error message"; (* End the borrows which borrow from the value, at the exception of the borrow we want to promote *) let bids = BorrowId.Set.remove l bids in - let cc = end_borrows config bids in + let cc = end_borrows meta config bids in (* Promote the loan - TODO: this will fail if the value contains * any loans. In practice, it shouldn't, but we could also * look for loans inside the value and end them before promoting * the borrow. *) - let cc = comp cc (promote_shared_loan_to_mut_loan l) in + let cc = comp cc (promote_shared_loan_to_mut_loan meta l) in (* Promote the borrow - the value should have been checked by {!promote_shared_loan_to_mut_loan} *) let cc = comp cc (fun cf borrowed_value -> - replace_reserved_borrow_with_mut_borrow l cf borrowed_value) + replace_reserved_borrow_with_mut_borrow meta l cf borrowed_value) in (* Continue *) cc cf ctx) | _, Abstract _ -> (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) - raise - (Failure + craise + meta "Can't activate a reserved mutable borrow referencing a loan inside\n\ - \ an abstraction") + \ an abstraction" -let destructure_abs (abs_kind : abs_kind) (can_end : bool) +let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (destructure_shared_values : bool) (ctx : eval_ctx) (abs0 : abs) : abs = (* Accumulator to store the destructured values *) let avalues = ref [] in @@ -1605,7 +1606,7 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) ignore the children altogether. Instead, we explore them and make sure we don't register values while doing so. *) - let push_fail _ = raise (Failure "Unreachable") in + let push_fail _ = craise meta "Unreachable" in (* Function to explore an avalue and destructure it *) let rec list_avalues (allow_borrows : bool) (push : typed_avalue -> unit) (av : typed_avalue) : unit = @@ -1620,7 +1621,7 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) match lc with | ASharedLoan (bids, sv, child_av) -> (* We don't support nested borrows for now *) - assert (not (value_has_borrows ctx sv.value)); + cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; (* Destructure the shared value *) let avl, sv = if destructure_shared_values then list_values sv else ([], sv) @@ -1647,8 +1648,8 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) push { value; ty } | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) - assert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)); - assert (opt_bid = None); + cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert (opt_bid = None) meta "TODO: error message"; (* Simply explore the child *) list_avalues false push_fail child_av | AEndedMutLoan @@ -1658,12 +1659,12 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) { child = child_av; given_back = _; given_back_meta = _ } | AIgnoredSharedLoan child_av -> (* We don't support nested borrows for now *) - assert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)); + cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; (* Simply explore the child *) list_avalues false push_fail child_av) | ABorrow bc -> ( (* Sanity check - rem.: may be redundant with [push_fail] *) - assert allow_borrows; + cassert allow_borrows meta "TODO: error message"; (* Explore the borrow content *) match bc with | AMutBorrow (bid, child_av) -> @@ -1678,19 +1679,19 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) push av | AIgnoredMutBorrow (opt_bid, child_av) -> (* We don't support nested borrows for now *) - assert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)); - assert (opt_bid = None); + cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert (opt_bid = None) meta "TODO: error message"; (* Just explore the child *) list_avalues false push_fail child_av | AEndedIgnoredMutBorrow { child = child_av; given_back = _; given_back_meta = _ } -> (* We don't support nested borrows for now *) - assert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)); + cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; (* Just explore the child *) list_avalues false push_fail child_av | AProjSharedBorrow asb -> (* We don't support nested borrows *) - assert (asb = []); + cassert (asb = []) meta "Nested borrows are not supported yet"; (* Nothing specific to do *) () | AEndedMutBorrow _ | AEndedSharedBorrow -> @@ -1698,11 +1699,11 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) be in the context anymore (if we end *one* borrow in an abstraction, we have to end them all and remove the abstraction from the context) *) - raise (Failure "Unreachable")) + craise meta "Unreachable") | ASymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) - assert (not (ty_has_borrows ctx.type_ctx.type_infos ty)) + cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta "TODO: error message" and list_values (v : typed_value) : typed_avalue list * typed_value = let ty = v.ty in match v.value with @@ -1714,19 +1715,19 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) let avl = List.concat avll in let adt = { adt with field_values } in (avl, { v with value = VAdt adt }) - | VBottom -> raise (Failure "Unreachable") + | VBottom -> craise meta "Unreachable" | VBorrow _ -> (* We don't support nested borrows for now *) - raise (Failure "Unreachable") + craise meta "Unreachable" | VLoan lc -> ( match lc with | VSharedLoan (bids, sv) -> let avl, sv = list_values sv in if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) - assert (ty_no_regions ty); + cassert (ty_no_regions ty) meta "The shared value can't contain loans nor borrows"; let av : typed_avalue = - assert (not (value_has_loans_or_borrows ctx sv.value)); + cassert (not (value_has_loans_or_borrows ctx sv.value)) meta "The shared value can't contain loans nor borrows"; (* We introduce fresh ids for the symbolic values *) let mk_value_with_fresh_sids (v : typed_value) : typed_value = let visitor = @@ -1747,11 +1748,11 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) let avl = List.append [ av ] avl in (avl, sv)) else (avl, { v with value = VLoan (VSharedLoan (bids, sv)) }) - | VMutLoan _ -> raise (Failure "Unreachable")) + | VMutLoan _ -> craise meta "Unreachable") | VSymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) - assert (not (ty_has_borrows ctx.type_ctx.type_infos ty)); + cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta "TODO: error message"; ([], v) in @@ -1761,14 +1762,14 @@ let destructure_abs (abs_kind : abs_kind) (can_end : bool) (* Update *) { abs0 with avalues; kind = abs_kind; can_end } -let abs_is_destructured (destructure_shared_values : bool) (ctx : eval_ctx) +let abs_is_destructured (meta : Meta.meta) (destructure_shared_values : bool) (ctx : eval_ctx) (abs : abs) : bool = let abs' = - destructure_abs abs.kind abs.can_end destructure_shared_values ctx abs + destructure_abs meta abs.kind abs.can_end destructure_shared_values ctx abs in abs = abs' -let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) +let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (destructure_shared_values : bool) (ctx : eval_ctx) (v : typed_value) : abs list = (* Convert the value to a list of avalues *) @@ -1851,20 +1852,20 @@ let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) (avl, { v with value = VAdt adt }) | VBorrow bc -> ( let _, ref_ty, kind = ty_as_ref ty in - assert (ty_no_regions ref_ty); + cassert (ty_no_regions ref_ty) meta "TODO: error message"; (* Sanity check *) - assert allow_borrows; + cassert allow_borrows meta "TODO: error message"; (* Convert the borrow content *) match bc with | VSharedBorrow bid -> - assert (ty_no_regions ref_ty); + cassert (ty_no_regions ref_ty) meta "TODO: error message"; let ty = TRef (RFVar r_id, ref_ty, kind) in let value = ABorrow (ASharedBorrow bid) in ([ { value; ty } ], v) | VMutBorrow (bid, bv) -> let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) - assert (not (value_has_borrows ctx bv.value)); + cassert (not (value_has_borrows ctx bv.value)) meta "Nested borrows are not supported yet"; (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) let ty = TRef (RFVar r_id, ref_ty, kind) in let ignored = mk_aignored ref_ty in @@ -1877,16 +1878,16 @@ let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) (av :: avl, value) | VReservedMutBorrow _ -> (* This borrow should have been activated *) - raise (Failure "Unexpected")) + craise meta "Unexpected") | VLoan lc -> ( match lc with | VSharedLoan (bids, sv) -> let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) - assert (not (value_has_borrows ctx sv.value)); + cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - assert (ty_no_regions ty); + cassert (ty_no_regions ty) meta "TODO: error message"; let ty = mk_ref_ty (RFVar r_id) ty RShared in let ignored = mk_aignored ty in (* Rem.: the shared value might contain loans *) @@ -1904,7 +1905,7 @@ let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) | VMutLoan bid -> (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - assert (ty_no_regions ty); + cassert (ty_no_regions ty) meta "TODO: error message"; let ty = mk_ref_ty (RFVar r_id) ty RMut in let ignored = mk_aignored ty in let av = ALoan (AMutLoan (bid, ignored)) in @@ -1913,7 +1914,7 @@ let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) | VSymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - assert (not (value_has_borrows ctx v.value)); + cassert (not (value_has_borrows ctx v.value)) meta "TODO: error message"; (* Return nothing *) ([], v) in @@ -1954,7 +1955,7 @@ type merge_abstraction_info = { - all the borrows are destructured (for instance, shared loans can't contain shared loans). *) -let compute_merge_abstraction_info (ctx : eval_ctx) (abs : abs) : +let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) (abs : abs) : merge_abstraction_info = let loans : loan_id_set ref = ref BorrowId.Set.empty in let borrows : borrow_id_set ref = ref BorrowId.Set.empty in @@ -1967,26 +1968,26 @@ let compute_merge_abstraction_info (ctx : eval_ctx) (abs : abs) : in let push_loans ids (lc : g_loan_content_with_ty) : unit = - assert (BorrowId.Set.disjoint !loans ids); + cassert (BorrowId.Set.disjoint !loans ids) meta "TODO: error message"; loans := BorrowId.Set.union !loans ids; BorrowId.Set.iter (fun id -> - assert (not (BorrowId.Map.mem id !loan_to_content)); + cassert (not (BorrowId.Map.mem id !loan_to_content)) meta "TODO: error message"; loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans) ids in let push_loan id (lc : g_loan_content_with_ty) : unit = - assert (not (BorrowId.Set.mem id !loans)); + cassert (not (BorrowId.Set.mem id !loans)) meta "TODO: error message"; loans := BorrowId.Set.add id !loans; - assert (not (BorrowId.Map.mem id !loan_to_content)); + cassert (not (BorrowId.Map.mem id !loan_to_content)) meta "TODO: error message"; loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans in let push_borrow id (bc : g_borrow_content_with_ty) : unit = - assert (not (BorrowId.Set.mem id !borrows)); + cassert (not (BorrowId.Set.mem id !borrows)) meta "TODO: error message"; borrows := BorrowId.Set.add id !borrows; - assert (not (BorrowId.Map.mem id !borrow_to_content)); + cassert (not (BorrowId.Map.mem id !borrow_to_content)) meta "TODO: error message"; borrow_to_content := BorrowId.Map.add id bc !borrow_to_content; borrows_loans := BorrowId id :: !borrows_loans in @@ -2009,23 +2010,23 @@ let compute_merge_abstraction_info (ctx : eval_ctx) (abs : abs) : let ty = match Option.get env with | Concrete ty -> ty - | Abstract _ -> raise (Failure "Unreachable") + | Abstract _ -> craise meta "Unreachable" in (match lc with | VSharedLoan (bids, _) -> push_loans bids (Concrete (ty, lc)) - | VMutLoan _ -> raise (Failure "Unreachable")); + | VMutLoan _ -> craise meta "Unreachable"); (* Continue *) super#visit_loan_content env lc method! visit_borrow_content _ _ = (* Can happen if we explore shared values which contain borrows - i.e., if we have nested borrows (we forbid this for now) *) - raise (Failure "Unreachable") + craise meta "Unreachable" method! visit_aloan_content env lc = let ty = match Option.get env with - | Concrete _ -> raise (Failure "Unreachable") + | Concrete _ -> craise meta "Unreachable" | Abstract ty -> ty in (* Register the loans *) @@ -2035,14 +2036,14 @@ let compute_merge_abstraction_info (ctx : eval_ctx) (abs : abs) : | AEndedMutLoan _ | AEndedSharedLoan _ | AIgnoredMutLoan _ | AEndedIgnoredMutLoan _ | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) - raise (Failure "Unreachable")); + craise meta "Unreachable"); (* Continue *) super#visit_aloan_content env lc method! visit_aborrow_content env bc = let ty = match Option.get env with - | Concrete _ -> raise (Failure "Unreachable") + | Concrete _ -> craise meta "Unreachable" | Abstract ty -> ty in (* Explore the borrow content *) @@ -2056,18 +2057,18 @@ let compute_merge_abstraction_info (ctx : eval_ctx) (abs : abs) : | AsbProjReborrows _ -> (* Can only happen if the symbolic value (potentially) contains borrows - i.e., we have nested borrows *) - raise (Failure "Unreachable") + craise meta "Unreachable" in List.iter register asb | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedMutBorrow _ | AEndedSharedBorrow -> (* The abstraction has been destructured, so those shouldn't appear *) - raise (Failure "Unreachable")); + craise meta "Unreachable"); super#visit_aborrow_content env bc method! visit_symbolic_value _ sv = (* Sanity check: no borrows *) - assert (not (symbolic_value_has_borrows ctx sv)) + cassert (not (symbolic_value_has_borrows ctx sv)) meta "TODO: error message" end in @@ -2134,7 +2135,7 @@ type merge_duplicates_funcs = { Merge two abstractions into one, without updating the context. *) -let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) +let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) (abs0 : abs) (abs1 : abs) : abs = log#ldebug @@ -2145,8 +2146,8 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) (* Check that the abstractions are destructured *) if !Config.sanity_checks then ( let destructure_shared_values = true in - assert (abs_is_destructured destructure_shared_values ctx abs0); - assert (abs_is_destructured destructure_shared_values ctx abs1)); + cassert (abs_is_destructured meta destructure_shared_values ctx abs0) meta "Abstractions should be destructured"; + cassert (abs_is_destructured meta destructure_shared_values ctx abs1) meta "Abstractions should be destructured"); (* Compute the relevant information *) let { @@ -2156,7 +2157,7 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) loan_to_content = loan_to_content0; borrow_to_content = borrow_to_content0; } = - compute_merge_abstraction_info ctx abs0 + compute_merge_abstraction_info meta ctx abs0 in let { @@ -2166,14 +2167,14 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) loan_to_content = loan_to_content1; borrow_to_content = borrow_to_content1; } = - compute_merge_abstraction_info ctx abs1 + compute_merge_abstraction_info meta ctx abs1 in (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) if merge_funs = None then ( - assert (BorrowId.Set.disjoint borrows0 borrows1); - assert (BorrowId.Set.disjoint loans0 loans1)); + cassert (BorrowId.Set.disjoint borrows0 borrows1) meta "TODO: error message"; + cassert (BorrowId.Set.disjoint loans0 loans1)) meta "TODO: error message"; (* Merge. There are several cases: @@ -2214,7 +2215,7 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) in let filter_bids (bids : BorrowId.Set.t) : BorrowId.Set.t = let bids = BorrowId.Set.diff bids intersect in - assert (not (BorrowId.Set.is_empty bids)); + cassert (not (BorrowId.Set.is_empty bids)) meta "TODO: error message"; bids in let filter_bid (bid : BorrowId.id) : BorrowId.id option = @@ -2242,11 +2243,11 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) (Option.get merge_funs).merge_ashared_borrows id ty0 ty1 | AProjSharedBorrow _, AProjSharedBorrow _ -> (* Unreachable because requires nested borrows *) - raise (Failure "Unreachable") + craise meta "Unreachable" | _ -> (* Unreachable because those cases are ignored (ended/ignored borrows) or inconsistent *) - raise (Failure "Unreachable") + craise meta "Unreachable" in let merge_g_borrow_contents (bc0 : g_borrow_content_with_ty) @@ -2254,12 +2255,12 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) match (bc0, bc1) with | Concrete _, Concrete _ -> (* This can happen only in case of nested borrows *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Abstract (ty0, bc0), Abstract (ty1, bc1) -> merge_aborrow_contents ty0 bc0 ty1 bc1 | Concrete _, Abstract _ | Abstract _, Concrete _ -> (* TODO: is it really unreachable? *) - raise (Failure "Unreachable") + craise meta "Unreachable" in let merge_aloan_contents (ty0 : rty) (lc0 : aloan_content) (ty1 : rty) @@ -2277,7 +2278,7 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) (* Check that the sets of ids are the same - if it is not the case, it means we actually need to merge more than 2 avalues: we ignore this case for now *) - assert (BorrowId.Set.equal ids0 ids1); + cassert (BorrowId.Set.equal ids0 ids1) meta "Ids are not the same - Case ignored for now"; let ids = ids0 in if BorrowId.Set.is_empty ids then ( (* If the set of ids is empty, we can eliminate this shared loan. @@ -2289,10 +2290,10 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) to preserve (in practice it works because we destructure the shared values in the abstractions, and forbid nested borrows). *) - assert (not (value_has_loans_or_borrows ctx sv0.value)); - assert (not (value_has_loans_or_borrows ctx sv0.value)); - assert (is_aignored child0.value); - assert (is_aignored child1.value); + cassert (not (value_has_loans_or_borrows ctx sv0.value)) meta "TODO: error message"; + cassert (not (value_has_loans_or_borrows ctx sv0.value)) meta "TODO: error message"; + cassert (is_aignored child0.value) meta "TODO: error message"; + cassert (is_aignored child1.value) meta "TODO: error message"; None) else ( (* Register the loan ids *) @@ -2304,7 +2305,7 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) | _ -> (* Unreachable because those cases are ignored (ended/ignored borrows) or inconsistent *) - raise (Failure "Unreachable") + craise meta "Unreachable" in (* Note that because we may filter ids from a set of id, this function has @@ -2315,12 +2316,12 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) match (lc0, lc1) with | Concrete _, Concrete _ -> (* This can not happen: the values should have been destructured *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Abstract (ty0, lc0), Abstract (ty1, lc1) -> merge_aloan_contents ty0 lc0 ty1 lc1 | Concrete _, Abstract _ | Abstract _, Concrete _ -> (* TODO: is it really unreachable? *) - raise (Failure "Unreachable") + craise meta "Unreachable" in (* Note that we first explore the borrows/loans of [abs1], because we @@ -2361,12 +2362,12 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) a concrete borrow can only happen inside a shared loan *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Abstract (ty, bc) -> { value = ABorrow bc; ty }) | Some bc0, Some bc1 -> - assert (merge_funs <> None); + cassert (merge_funs <> None) meta "TODO: error message"; merge_g_borrow_contents bc0 bc1 - | None, None -> raise (Failure "Unreachable") + | None, None -> craise meta "Unreachable" in push_avalue av) | LoanId bid -> @@ -2399,15 +2400,15 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) | Concrete _ -> (* This shouldn't happen because the avalues should have been destructured. *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Abstract (ty, lc) -> ( match lc with | ASharedLoan (bids, sv, child) -> let bids = filter_bids bids in - assert (not (BorrowId.Set.is_empty bids)); - assert (is_aignored child.value); - assert ( - not (value_has_loans_or_borrows ctx sv.value)); + cassert (not (BorrowId.Set.is_empty bids)) meta "TODO: error message"; + cassert (is_aignored child.value) meta "TODO: error message"; + cassert ( + not (value_has_loans_or_borrows ctx sv.value)) meta "TODO: error message"; let lc = ASharedLoan (bids, sv, child) in set_loans_as_merged bids; Some { value = ALoan lc; ty } @@ -2418,11 +2419,11 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) | AIgnoredMutLoan _ | AEndedIgnoredMutLoan _ | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) - raise (Failure "Unreachable"))) + craise meta "Unreachable")) | Some lc0, Some lc1 -> - assert (merge_funs <> None); + cassert (merge_funs <> None) meta "TODO: error message"; merge_g_loan_contents lc0 lc1 - | None, None -> raise (Failure "Unreachable") + | None, None -> craise meta "Unreachable" in push_opt_avalue av)) borrows_loans; @@ -2440,7 +2441,7 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) match av.value with | ABorrow _ -> true | ALoan _ -> false - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in let aborrows, aloans = List.partition is_borrow avalues in List.append aborrows aloans @@ -2475,7 +2476,7 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) in (* Sanity check *) - if !Config.sanity_checks then assert (abs_is_destructured true ctx abs); + if !Config.sanity_checks then cassert (abs_is_destructured meta true ctx abs) meta "TODO: error message"; (* Return *) abs @@ -2486,7 +2487,7 @@ let ctx_merge_regions (ctx : eval_ctx) (rid : RegionId.id) let env = Substitute.env_subst_rids rsubst ctx.env in { ctx with env } -let merge_into_abstraction (abs_kind : abs_kind) (can_end : bool) +let merge_into_abstraction (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) (abs_id0 : AbstractionId.id) (abs_id1 : AbstractionId.id) : eval_ctx * AbstractionId.id = @@ -2496,7 +2497,7 @@ let merge_into_abstraction (abs_kind : abs_kind) (can_end : bool) (* Merge them *) let nabs = - merge_into_abstraction_aux abs_kind can_end merge_funs ctx abs0 abs1 + merge_into_abstraction_aux meta abs_kind can_end merge_funs ctx abs0 abs1 in (* Update the environment: replace the abstraction 1 with the result of the merge, diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 44f85d0a..5b84e2c0 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -9,6 +9,7 @@ open Contexts open Utils open TypesUtils open InterpreterUtils +open Errors (** The local logger *) let log = Logging.borrows_log @@ -94,22 +95,22 @@ let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) TODO: is there a way of deriving such a comparison? TODO: rename *) -let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) +let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool -> bool) (compare_regions : region -> region -> bool) (ty1 : rty) (ty2 : rty) : bool = - let compare = compare_rtys default combine compare_regions in + let compare = compare_rtys meta default combine compare_regions in (* Sanity check - TODO: don't do this at every recursive call *) - assert (ty_is_rty ty1 && ty_is_rty ty2); + cassert (ty_is_rty ty1 && ty_is_rty ty2) meta "ty1 or ty2 are not rty TODO"; (* Normalize the associated types *) match (ty1, ty2) with | TLiteral lit1, TLiteral lit2 -> - assert (lit1 = lit2); + cassert (lit1 = lit2) meta "Tlitrals are not equal TODO"; default | TAdt (id1, generics1), TAdt (id2, generics2) -> - assert (id1 = id2); + cassert (id1 = id2) meta "ids are not equal TODO"; (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) - assert (generics1.const_generics = generics2.const_generics); + cassert (generics1.const_generics = generics2.const_generics) meta "const generics are not the same"; (* We also ignore the trait refs *) @@ -143,7 +144,7 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) combine params_b tys_b | TRef (r1, ty1, kind1), TRef (r2, ty2, kind2) -> (* Sanity check *) - assert (kind1 = kind2); + cassert (kind1 = kind2) meta "kind1 and kind2 are not equal TODO"; (* Explanation for the case where we check if projections intersect: * the projections intersect if the borrows intersect or their contents * intersect. *) @@ -151,19 +152,19 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) let tys_b = compare ty1 ty2 in combine regions_b tys_b | TVar id1, TVar id2 -> - assert (id1 = id2); + cassert (id1 = id2) meta "Ids are not the same TODO"; default | TTraitType _, TTraitType _ -> (* The types should have been normalized. If after normalization we get trait types, we can consider them as variables *) - assert (ty1 = ty2); + cassert (ty1 = ty2) meta "The types are not normalized"; default | _ -> log#lerror (lazy ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ show_ty ty1 ^ "\n- ty2: " ^ show_ty ty2)); - raise (Failure "Unreachable") + craise meta "Unreachable" (** Check if two different projections intersect. This is necessary when giving a symbolic value to an abstraction: we need to check that @@ -172,14 +173,14 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) Note that the two abstractions have different views (in terms of regions) of the symbolic value (hence the two region types). *) -let projections_intersect (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) +let projections_intersect (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) (rset2 : RegionId.Set.t) : bool = let default = false in let combine b1 b2 = b1 || b2 in let compare_regions r1 r2 = region_in_set r1 rset1 && region_in_set r2 rset2 in - compare_rtys default combine compare_regions ty1 ty2 + compare_rtys meta default combine compare_regions ty1 ty2 (** Check if the first projection contains the second projection. We use this function when checking invariants. @@ -187,14 +188,14 @@ let projections_intersect (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) The regions in the types shouldn't be erased (this function will raise an exception otherwise). *) -let projection_contains (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) +let projection_contains (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) (rset2 : RegionId.Set.t) : bool = let default = true in let combine b1 b2 = b1 && b2 in let compare_regions r1 r2 = region_in_set r1 rset1 || not (region_in_set r2 rset2) in - compare_rtys default combine compare_regions ty1 ty2 + compare_rtys meta default combine compare_regions ty1 ty2 (** Lookup a loan content. @@ -204,7 +205,7 @@ let projection_contains (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) the {!InterpreterUtils.abs_or_var_id} is not necessarily {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.VarId} or {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.DummyVarId}: there can be concrete loans in abstractions (in the shared values). *) -let lookup_loan_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : +let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : (abs_or_var_id * g_loan_content) option = (* We store here whether we are inside an abstraction or a value - note that we * could also track that with the environment, it would probably be more idiomatic @@ -268,7 +269,7 @@ let lookup_loan_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : super#visit_aloan_content env lc method! visit_EBinding env bv v = - assert (Option.is_none !abs_or_var); + cassert (Option.is_none !abs_or_var) meta "TODO : error message "; abs_or_var := Some (match bv with @@ -278,7 +279,7 @@ let lookup_loan_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : abs_or_var := None method! visit_EAbs env abs = - assert (Option.is_none !abs_or_var); + cassert (Option.is_none !abs_or_var) meta "TODO : error message "; if ek.enter_abs then ( abs_or_var := Some (AbsId abs.abs_id); super#visit_EAbs env abs; @@ -293,17 +294,17 @@ let lookup_loan_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : with FoundGLoanContent lc -> ( match !abs_or_var with | Some abs_or_var -> Some (abs_or_var, lc) - | None -> raise (Failure "Inconsistent state")) + | None -> craise meta "Inconsistent state") (** Lookup a loan content. The loan is referred to by a borrow id. Raises an exception if no loan was found. *) -let lookup_loan (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : +let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : abs_or_var_id * g_loan_content = - match lookup_loan_opt ek l ctx with - | None -> raise (Failure "Unreachable") + match lookup_loan_opt meta ek l ctx with + | None -> craise meta "Unreachable" | Some res -> res (** Update a loan content. @@ -312,14 +313,14 @@ let lookup_loan (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : This is a helper function: it might break invariants. *) -let update_loan (ek : exploration_kind) (l : BorrowId.id) (nlc : loan_content) +let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nlc : loan_content) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one loan: when updating * inside values, we check we don't update more than one loan. Then, upon * returning we check that we updated at least once. *) let r = ref false in let update () : loan_content = - assert (not !r); + cassert (not !r) meta "TODO : error message "; r := true; nlc in @@ -366,7 +367,7 @@ let update_loan (ek : exploration_kind) (l : BorrowId.id) (nlc : loan_content) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one loan *) - assert !r; + cassert !r meta "No loan was updated"; ctx (** Update a abstraction loan content. @@ -375,14 +376,14 @@ let update_loan (ek : exploration_kind) (l : BorrowId.id) (nlc : loan_content) This is a helper function: it might break invariants. *) -let update_aloan (ek : exploration_kind) (l : BorrowId.id) (nlc : aloan_content) +let update_aloan (meta : Meta.meta ) (ek : exploration_kind) (l : BorrowId.id) (nlc : aloan_content) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one loan: when updating * inside values, we check we don't update more than one loan. Then, upon * returning we check that we updated at least once. *) let r = ref false in let update () : aloan_content = - assert (not !r); + cassert (not !r) meta "TODO : error message "; r := true; nlc in @@ -415,7 +416,7 @@ let update_aloan (ek : exploration_kind) (l : BorrowId.id) (nlc : aloan_content) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one loan *) - assert !r; + cassert !r meta "No loan was uodated"; ctx (** Lookup a borrow content from a borrow id. *) @@ -481,10 +482,10 @@ let lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) Raise an exception if no loan was found *) -let lookup_borrow (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : +let lookup_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : g_borrow_content = match lookup_borrow_opt ek l ctx with - | None -> raise (Failure "Unreachable") + | None -> craise meta "Unreachable" | Some lc -> lc (** Update a borrow content. @@ -493,14 +494,14 @@ let lookup_borrow (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : This is a helper function: it might break invariants. *) -let update_borrow (ek : exploration_kind) (l : BorrowId.id) +let update_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nbc : borrow_content) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one borrow: when updating * inside values, we check we don't update more than one borrow. Then, upon * returning we check that we updated at least once. *) let r = ref false in let update () : borrow_content = - assert (not !r); + cassert (not !r) meta "TODO : error message "; r := true; nbc in @@ -541,7 +542,7 @@ let update_borrow (ek : exploration_kind) (l : BorrowId.id) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one borrow *) - assert !r; + cassert !r meta "No borrow was updated"; ctx (** Update an abstraction borrow content. @@ -550,14 +551,14 @@ let update_borrow (ek : exploration_kind) (l : BorrowId.id) This is a helper function: it might break invariants. *) -let update_aborrow (ek : exploration_kind) (l : BorrowId.id) (nv : avalue) +let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nv : avalue) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one borrow: when updating * inside values, we check we don't update more than one borrow. Then, upon * returning we check that we updated at least once. *) let r = ref false in let update () : avalue = - assert (not !r); + cassert (not !r) meta ""; r := true; nv in @@ -588,7 +589,7 @@ let update_aborrow (ek : exploration_kind) (l : BorrowId.id) (nv : avalue) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one borrow *) - assert !r; + cassert !r meta "No borrow was updated"; ctx (** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) @@ -666,13 +667,13 @@ let get_first_outer_loan_or_borrow_in_value (with_borrows : bool) | FoundLoanContent lc -> Some (LoanContent lc) | FoundBorrowContent bc -> Some (BorrowContent bc) -let proj_borrows_intersects_proj_loans +let proj_borrows_intersects_proj_loans (meta : Meta.meta) (proj_borrows : RegionId.Set.t * symbolic_value * rty) (proj_loans : RegionId.Set.t * symbolic_value) : bool = let b_regions, b_sv, b_ty = proj_borrows in let l_regions, l_sv = proj_loans in if same_symbolic_id b_sv l_sv then - projections_intersect l_sv.sv_ty l_regions b_ty b_regions + projections_intersect meta l_sv.sv_ty l_regions b_ty b_regions else false (** Result of looking up aproj_borrows which intersect a given aproj_loans in @@ -700,24 +701,25 @@ type looked_up_aproj_borrows = This is a helper function. *) -let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) +let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) (lookup_shared : bool) (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : looked_up_aproj_borrows option = let found : looked_up_aproj_borrows option ref = ref None in let set_non_shared ((id, ty) : AbstractionId.id * rty) : unit = match !found with | None -> found := Some (NonSharedProj (id, ty)) - | Some _ -> raise (Failure "Unreachable") + | Some _ -> craise meta "Unreachable" in let add_shared (x : AbstractionId.id * rty) : unit = match !found with | None -> found := Some (SharedProjs [ x ]) | Some (SharedProjs pl) -> found := Some (SharedProjs (x :: pl)) - | Some (NonSharedProj _) -> raise (Failure "Unreachable") + | Some (NonSharedProj _) -> craise meta "Unreachable" in let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = if proj_borrows_intersects_proj_loans + meta (abs.regions, sv', proj_ty) (regions, sv) then @@ -733,7 +735,7 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) method! visit_abstract_shared_borrow abs asb = (* Sanity check *) (match !found with - | Some (NonSharedProj _) -> raise (Failure "Unreachable") + | Some (NonSharedProj _) -> craise meta "Unreachable" | _ -> ()); (* Explore *) if lookup_shared then @@ -772,20 +774,20 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) Returns the id of the owning abstraction, and the projection type used in this abstraction. *) -let lookup_intersecting_aproj_borrows_not_shared_opt (regions : RegionId.Set.t) +let lookup_intersecting_aproj_borrows_not_shared_opt (meta : Meta.meta) (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : (AbstractionId.id * rty) option = let lookup_shared = false in - match lookup_intersecting_aproj_borrows_opt lookup_shared regions sv ctx with + match lookup_intersecting_aproj_borrows_opt meta lookup_shared regions sv ctx with | None -> None | Some (NonSharedProj (abs_id, rty)) -> Some (abs_id, rty) - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" (** Similar to {!lookup_intersecting_aproj_borrows_opt}, but updates the values. This is a helper function: it might break invariants. *) -let update_intersecting_aproj_borrows (can_update_shared : bool) +let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bool) (update_shared : AbstractionId.id -> rty -> abstract_shared_borrows) (update_non_shared : AbstractionId.id -> rty -> aproj) (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx @@ -793,16 +795,17 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) (* Small helpers for sanity checks *) let shared = ref None in let add_shared () = - match !shared with None -> shared := Some true | Some b -> assert b + match !shared with None -> shared := Some true | Some b -> cassert b meta "TODO : error message " in let set_non_shared () = match !shared with | None -> shared := Some false - | Some _ -> raise (Failure "Found unexpected intersecting proj_borrows") + | Some _ -> craise meta "Found unexpected intersecting proj_borrows" in let check_proj_borrows is_shared abs sv' proj_ty = if proj_borrows_intersects_proj_loans + meta (abs.regions, sv', proj_ty) (regions, sv) then ( @@ -818,7 +821,7 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) method! visit_abstract_shared_borrows abs asb = (* Sanity check *) - (match !shared with Some b -> assert b | _ -> ()); + (match !shared with Some b -> cassert b meta "TODO : error message " | _ -> ()); (* Explore *) if can_update_shared then let abs = Option.get abs in @@ -850,7 +853,7 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Check that we updated the context at least once *) - assert (Option.is_some !shared); + cassert (Option.is_some !shared) meta "Context was not updated at least once"; (* Return *) ctx @@ -861,11 +864,11 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) This is a helper function: it might break invariants. *) -let update_intersecting_aproj_borrows_non_shared (regions : RegionId.Set.t) +let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) (regions : RegionId.Set.t) (sv : symbolic_value) (nv : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = false in - let update_shared _ _ = raise (Failure "Unexpected") in + let update_shared _ _ = craise meta "Unexpected" in let updated = ref false in let update_non_shared _ _ = (* We can update more than one borrow! *) @@ -874,11 +877,11 @@ let update_intersecting_aproj_borrows_non_shared (regions : RegionId.Set.t) in (* Update *) let ctx = - update_intersecting_aproj_borrows can_update_shared update_shared + update_intersecting_aproj_borrows meta can_update_shared update_shared update_non_shared regions sv ctx in (* Check that we updated at least once *) - assert !updated; + cassert !updated meta "Not updated at least once"; (* Return *) ctx @@ -887,14 +890,14 @@ let update_intersecting_aproj_borrows_non_shared (regions : RegionId.Set.t) This is a helper function: it might break invariants. *) -let remove_intersecting_aproj_borrows_shared (regions : RegionId.Set.t) +let remove_intersecting_aproj_borrows_shared (meta : Meta.meta) (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = true in let update_shared _ _ = [] in - let update_non_shared _ _ = raise (Failure "Unexpected") in + let update_non_shared _ _ = craise meta "Unexpected" in (* Update *) - update_intersecting_aproj_borrows can_update_shared update_shared + update_intersecting_aproj_borrows meta can_update_shared update_shared update_non_shared regions sv ctx (** Updates the proj_loans intersecting some projection. @@ -928,12 +931,12 @@ let remove_intersecting_aproj_borrows_shared (regions : RegionId.Set.t) Note that the symbolic value at this place is necessarily equal to [sv], which is why we don't give it as parameters. *) -let update_intersecting_aproj_loans (proj_regions : RegionId.Set.t) +let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) (subst : abs -> (msymbolic_value * aproj) list -> aproj) (ctx : eval_ctx) : eval_ctx = (* *) - assert (ty_is_rty proj_ty); + cassert (ty_is_rty proj_ty) meta "proj_ty is not rty TODO"; (* Small helpers for sanity checks *) let updated = ref false in let update abs local_given_back : aproj = @@ -955,9 +958,9 @@ let update_intersecting_aproj_loans (proj_regions : RegionId.Set.t) | AProjLoans (sv', given_back) -> let abs = Option.get abs in if same_symbolic_id sv sv' then ( - assert (sv.sv_ty = sv'.sv_ty); + cassert (sv.sv_ty = sv'.sv_ty) meta "TODO : error message "; if - projections_intersect proj_ty proj_regions sv'.sv_ty abs.regions + projections_intersect meta proj_ty proj_regions sv'.sv_ty abs.regions then update abs given_back else super#visit_aproj (Some abs) sproj) else super#visit_aproj (Some abs) sproj @@ -966,7 +969,7 @@ let update_intersecting_aproj_loans (proj_regions : RegionId.Set.t) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Check that we updated the context at least once *) - assert !updated; + cassert !updated meta "Context was not updated at least once"; (* Return *) ctx @@ -980,13 +983,13 @@ let update_intersecting_aproj_loans (proj_regions : RegionId.Set.t) Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) -let lookup_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) +let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) (ctx : eval_ctx) : (msymbolic_value * aproj) list = (* Small helpers for sanity checks *) let found = ref None in let set_found x = (* There is at most one projector which corresponds to the description *) - assert (Option.is_none !found); + cassert (Option.is_none !found) meta "More than one projecto corresponds to the description"; found := Some x in (* The visitor *) @@ -1004,9 +1007,9 @@ let lookup_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) super#visit_aproj abs sproj | AProjLoans (sv', given_back) -> let abs = Option.get abs in - assert (abs.abs_id = abs_id); + cassert (abs.abs_id = abs_id) meta "TODO : error message "; if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); + cassert (sv' = sv) meta "TODO : error message "; set_found given_back) else ()); super#visit_aproj abs sproj @@ -1025,13 +1028,13 @@ let lookup_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) -let update_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) +let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = (* We update at most once *) - assert (not !found); + cassert (not !found) meta "Updated more than once"; found := true; nproj in @@ -1050,9 +1053,9 @@ let update_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) super#visit_aproj abs sproj | AProjLoans (sv', _) -> let abs = Option.get abs in - assert (abs.abs_id = abs_id); + cassert (abs.abs_id = abs_id) meta "TODO : error message "; if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); + cassert (sv' = sv) meta "TODO : error message "; update ()) else super#visit_aproj (Some abs) sproj end @@ -1060,7 +1063,7 @@ let update_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Sanity check *) - assert !found; + cassert !found meta "TODO : error message "; (* Return *) ctx @@ -1074,13 +1077,13 @@ let update_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) TODO: factorize with {!update_aproj_loans}? *) -let update_aproj_borrows (abs_id : AbstractionId.id) (sv : symbolic_value) +let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = (* We update at most once *) - assert (not !found); + cassert (not !found) meta "Updated more than once"; found := true; nproj in @@ -1099,9 +1102,9 @@ let update_aproj_borrows (abs_id : AbstractionId.id) (sv : symbolic_value) super#visit_aproj abs sproj | AProjBorrows (sv', _proj_ty) -> let abs = Option.get abs in - assert (abs.abs_id = abs_id); + cassert (abs.abs_id = abs_id) meta "TODO : error message "; if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); + cassert (sv' = sv) meta "TODO : error message "; update ()) else super#visit_aproj (Some abs) sproj end @@ -1109,7 +1112,7 @@ let update_aproj_borrows (abs_id : AbstractionId.id) (sv : symbolic_value) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Sanity check *) - assert !found; + cassert !found meta "TODO : error message "; (* Return *) ctx @@ -1118,18 +1121,18 @@ let update_aproj_borrows (abs_id : AbstractionId.id) (sv : symbolic_value) Converts an {!Values.aproj.AProjLoans} to an {!Values.aproj.AEndedProjLoans}. The projector is identified by a symbolic value and an abstraction id. *) -let update_aproj_loans_to_ended (abs_id : AbstractionId.id) +let update_aproj_loans_to_ended (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Lookup the projector of loans *) - let given_back = lookup_aproj_loans abs_id sv ctx in + let given_back = lookup_aproj_loans meta abs_id sv ctx in (* Create the new value for the projector *) let nproj = AEndedProjLoans (sv, given_back) in (* Insert it *) - let ctx = update_aproj_loans abs_id sv nproj ctx in + let ctx = update_aproj_loans meta abs_id sv nproj ctx in (* Return *) ctx -let no_aproj_over_symbolic_in_context (sv : symbolic_value) (ctx : eval_ctx) : +let no_aproj_over_symbolic_in_context (meta : Meta.meta) (sv : symbolic_value) (ctx : eval_ctx) : unit = (* The visitor *) let obj = @@ -1146,7 +1149,7 @@ let no_aproj_over_symbolic_in_context (sv : symbolic_value) (ctx : eval_ctx) : in (* Apply *) try obj#visit_eval_ctx () ctx - with Found -> raise (Failure "update_aproj_loans_to_ended: failed") + with Found -> craise meta "update_aproj_loans_to_ended: failed" (** Helper function @@ -1155,7 +1158,7 @@ let no_aproj_over_symbolic_in_context (sv : symbolic_value) (ctx : eval_ctx) : **Remark:** we don't take the *ignored* mut/shared loans into account. *) -let get_first_non_ignored_aloan_in_abstraction (abs : abs) : +let get_first_non_ignored_aloan_in_abstraction (meta : Meta.meta) (abs : abs) : borrow_ids_or_symbolic_value option = (* Explore to find a loan *) let obj = @@ -1184,7 +1187,7 @@ let get_first_non_ignored_aloan_in_abstraction (abs : abs) : | VMutLoan _ -> (* The mut loan linked to the mutable borrow present in a shared * value in an abstraction should be in an AProjBorrows *) - raise (Failure "Unreachable") + craise meta "Unreachable" | VSharedLoan (bids, _) -> raise (FoundBorrowIds (Borrows bids)) method! visit_aproj env sproj = @@ -1208,9 +1211,9 @@ let get_first_non_ignored_aloan_in_abstraction (abs : abs) : (* There are loan projections over symbolic values *) Some (SymbolicValue sv) -let lookup_shared_value_opt (ctx : eval_ctx) (bid : BorrowId.id) : +let lookup_shared_value_opt (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId.id) : typed_value option = - match lookup_loan_opt ek_all bid ctx with + match lookup_loan_opt meta ek_all bid ctx with | None -> None | Some (_, lc) -> ( match lc with @@ -1218,5 +1221,5 @@ let lookup_shared_value_opt (ctx : eval_ctx) (bid : BorrowId.id) : Some sv | _ -> None) -let lookup_shared_value (ctx : eval_ctx) (bid : BorrowId.id) : typed_value = - Option.get (lookup_shared_value_opt ctx bid) +let lookup_shared_value (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId.id) : typed_value = + Option.get (lookup_shared_value_opt meta ctx bid) diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 66c97cde..b07ba943 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -11,6 +11,7 @@ open InterpreterBorrows open InterpreterLoopsCore open InterpreterLoopsMatchCtxs open InterpreterLoopsJoinCtxs +open Errors (** The local logger *) let log = Logging.loops_fixed_point_log @@ -135,7 +136,7 @@ let cleanup_fresh_values_and_abs (config : config) (fixed_ids : ids_sets) : called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) +let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) @@ -143,7 +144,7 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) match av.value with | ABorrow _ -> true | ALoan _ -> false - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in let aborrows, aloans = List.partition is_borrow abs.avalues in @@ -156,13 +157,13 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) let get_borrow_id (av : typed_avalue) : BorrowId.id = match av.value with | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in let get_loan_id (av : typed_avalue) : BorrowId.id = match av.value with | ALoan (AMutLoan (lid, _)) -> lid | ALoan (ASharedLoan (lids, _, _)) -> BorrowId.Set.min_elt lids - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in (* We use ordered maps to reorder the borrows and loans *) let reorder (get_bid : typed_avalue -> BorrowId.id) @@ -186,7 +187,7 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) { ctx with env } -let prepare_ashared_loans (loop_id : LoopId.id option) : cm_fun = +let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_fun = fun cf ctx0 -> let ctx = ctx0 in (* Compute the set of borrows which appear in the abstractions, so that @@ -266,12 +267,12 @@ let prepare_ashared_loans (loop_id : LoopId.id option) : cm_fun = borrow_substs := (lid, nlid) :: !borrow_substs; (* Rem.: the below sanity checks are not really necessary *) - assert (AbstractionId.Set.is_empty abs.parents); - assert (abs.original_parents = []); - assert (RegionId.Set.is_empty abs.ancestors_regions); + cassert (AbstractionId.Set.is_empty abs.parents) meta "abs.parents is not empty TODO"; + cassert (abs.original_parents = []) meta "original_parents is not empty TODO"; + cassert (RegionId.Set.is_empty abs.ancestors_regions) meta "ancestors_regions is not empty TODO"; (* Introduce the new abstraction for the shared values *) - assert (ty_no_regions sv.ty); + cassert (ty_no_regions sv.ty) meta "TODO : error message "; let rty = sv.ty in (* Create the shared loan child *) @@ -322,7 +323,7 @@ let prepare_ashared_loans (loop_id : LoopId.id option) : cm_fun = let collect_shared_values_in_abs (abs : abs) : unit = let collect_shared_value lids (sv : typed_value) = (* Sanity check: we don't support nested borrows for now *) - assert (not (value_has_borrows ctx sv.value)); + cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows not supported yet"; (* Filter the loan ids whose corresponding borrows appear in abstractions (see the documentation of the function) *) @@ -356,7 +357,7 @@ let prepare_ashared_loans (loop_id : LoopId.id option) : cm_fun = TODO: implement this more general behavior. *) method! visit_symbolic_value env sv = - assert (not (symbolic_value_has_borrows ctx sv)); + cassert (not (symbolic_value_has_borrows ctx sv)) meta "There should be no symbolic values with borrows inside the abstraction"; super#visit_symbolic_value env sv end in @@ -432,11 +433,11 @@ let prepare_ashared_loans (loop_id : LoopId.id option) : cm_fun = SymbolicAst.IntroSymbolic (ctx, None, sv, VaSingleValue v, e)) e !sid_subst) -let prepare_ashared_loans_no_synth (loop_id : LoopId.id) (ctx : eval_ctx) : +let prepare_ashared_loans_no_synth (meta : Meta.meta) (loop_id : LoopId.id) (ctx : eval_ctx) : eval_ctx = - get_cf_ctx_no_synth (prepare_ashared_loans (Some loop_id)) ctx + get_cf_ctx_no_synth (prepare_ashared_loans meta (Some loop_id)) ctx -let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) +let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id : LoopId.id) (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : eval_ctx * ids_sets * abs RegionGroupId.Map.t = (* The continuation for when we exit the loop - we register the @@ -453,7 +454,7 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) For more details, see the comments for {!prepare_ashared_loans} *) - let ctx = prepare_ashared_loans_no_synth loop_id ctx0 in + let ctx = prepare_ashared_loans_no_synth meta loop_id ctx0 in (* Debug *) log#ldebug @@ -472,15 +473,15 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) | Return | Panic | Break _ -> None | Unit -> (* See the comment in {!eval_loop} *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Continue i -> (* For now we don't support continues to outer loops *) - assert (i = 0); + cassert (i = 0) meta "Continues to outer loops not supported yet"; register_ctx ctx; None | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> (* We don't support nested loops for now *) - raise (Failure "Nested loops are not supported for now") + craise meta "Nested loops are not supported for now" in (* The fixed ids. They are the ids of the original ctx, after we ended @@ -573,7 +574,7 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) log#ldebug (lazy "compute_fixed_point: equiv_ctx:"); let fixed_ids = compute_fixed_ids [ ctx1; ctx2 ] in let check_equivalent = true in - let lookup_shared_value _ = raise (Failure "Unreachable") in + let lookup_shared_value _ = craise meta "Unreachable" in Option.is_some (match_ctxs check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx1 ctx2) @@ -581,10 +582,10 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) let max_num_iter = Config.loop_fixed_point_max_num_iters in let rec compute_fixed_point (ctx : eval_ctx) (i0 : int) (i : int) : eval_ctx = if i = 0 then - raise - (Failure + craise + meta ("Could not compute a loop fixed point in " ^ string_of_int i0 - ^ " iterations")) + ^ " iterations") else (* Evaluate the loop body to register the different contexts upon reentry *) let _ = eval_loop_body cf_exit_loop_body ctx in @@ -633,10 +634,10 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> - assert (loop_id' = loop_id); - assert (kind = LoopSynthInput); + cassert (loop_id' = loop_id) meta "TODO : error message "; + cassert (kind = LoopSynthInput) meta "TODO : error message "; (* The abstractions introduced so far should be endable *) - assert (abs.can_end = true); + cassert (abs.can_end = true) meta "The abstractions introduced so far can not end"; add_aid abs.abs_id; abs | _ -> abs @@ -669,12 +670,12 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) None | Break _ -> (* We enforce that we can't get there: see {!PrePasses.remove_loop_breaks} *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Unit | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> (* For why we can't get [Unit], see the comments inside {!eval_loop_concrete}. For [EndEnterLoop] and [EndContinue]: we don't support nested loops for now. *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Return -> log#ldebug (lazy "compute_loop_entry_fixed_point: cf_loop: Return"); (* Should we consume the return value and pop the frame? @@ -693,9 +694,9 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) in (* By default, the [SynthInput] abs can't end *) let ctx = ctx_set_abs_can_end ctx abs_id true in - assert ( + cassert ( let abs = ctx_lookup_abs ctx abs_id in - abs.kind = SynthInput rg_id); + abs.kind = SynthInput rg_id) meta "TODO : error message "; (* End this abstraction *) let ctx = InterpreterBorrows.end_abstraction_no_synth config abs_id ctx @@ -717,14 +718,14 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) let _ = RegionGroupId.Map.iter (fun _ ids -> - assert (AbstractionId.Set.disjoint !aids_union ids); + cassert (AbstractionId.Set.disjoint !aids_union ids) meta "The sets of abstractions we need to end per region group are not pairwise disjoint"; aids_union := AbstractionId.Set.union ids !aids_union) !fp_ended_aids in (* We also check that all the regions need to end - this is not necessary per se, but if it doesn't happen it is bizarre and worth investigating... *) - assert (AbstractionId.Set.equal !aids_union !fp_aids); + cassert (AbstractionId.Set.equal !aids_union !fp_aids) meta "Not all regions need to end TODO"; (* Merge the abstractions which need to be merged, and compute the map from region id to abstraction id *) @@ -781,7 +782,7 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) fp := fp'; id0 := id0'; () - with ValueMatchFailure _ -> raise (Failure "Unexpected")) + with ValueMatchFailure _ -> craise meta "Unexpected") ids; (* Register the mapping *) let abs = ctx_lookup_abs !fp !id0 in @@ -792,7 +793,7 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) (* Reorder the loans and borrows in the fresh abstractions in the fixed-point *) let fp = - reorder_loans_borrows_in_fresh_abs (Option.get !fixed_ids).aids !fp + reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (Option.get !fixed_ids).aids !fp in (* Update the abstraction's [can_end] field and their kinds. @@ -814,8 +815,8 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> - assert (loop_id' = loop_id); - assert (kind = LoopSynthInput); + cassert (loop_id' = loop_id) meta "TODO : error message "; + cassert (kind = LoopSynthInput) meta "TODO : error message "; let kind : abs_kind = if remove_rg_id then Loop (loop_id, None, LoopSynthInput) else abs.kind @@ -849,7 +850,7 @@ let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) (* Return *) (fp, fixed_ids, rg_to_abs) -let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) +let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_sets) (src_ctx : eval_ctx) (tgt_ctx : eval_ctx) : borrow_loan_corresp = log#ldebug (lazy @@ -877,10 +878,10 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) let fixed_ids = ids_sets_empty_borrows_loans fixed_ids in let open InterpreterBorrowsCore in let lookup_shared_loan lid ctx : typed_value = - match snd (lookup_loan ek_all lid ctx) with + match snd (lookup_loan meta ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in let lookup_in_src id = lookup_shared_loan id src_ctx in @@ -940,7 +941,7 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) ids.loan_ids in (* Check that the loan and borrows are related *) - assert (BorrowId.Set.equal ids.borrow_ids loan_ids)) + cassert (BorrowId.Set.equal ids.borrow_ids loan_ids) meta "The loan and borrows are not related") new_absl; (* For every target abstraction (going back to the [list_nth_mut] example, @@ -983,7 +984,7 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) loan_to_borrow_id_map = tgt_loan_to_borrow; } -let compute_fp_ctx_symbolic_values (ctx : eval_ctx) (fp_ctx : eval_ctx) : +let compute_fp_ctx_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) (fp_ctx : eval_ctx) : SymbolicValueId.Set.t * symbolic_value list = let old_ids, _ = compute_ctx_ids ctx in let fp_ids, fp_ids_maps = compute_ctx_ids fp_ctx in @@ -1064,10 +1065,10 @@ let compute_fp_ctx_symbolic_values (ctx : eval_ctx) (fp_ctx : eval_ctx) : method! visit_VSharedBorrow env bid = let open InterpreterBorrowsCore in let v = - match snd (lookup_loan ek_all bid fp_ctx) with + match snd (lookup_loan meta ek_all bid fp_ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in self#visit_typed_value env v diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 88f290c4..fc2a97e5 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -7,6 +7,7 @@ open InterpreterUtils open InterpreterBorrows open InterpreterLoopsCore open InterpreterLoopsMatchCtxs +open Errors (** The local logger *) let log = Logging.loops_join_ctxs_log @@ -18,7 +19,7 @@ let log = Logging.loops_join_ctxs_log called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) +let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) @@ -26,7 +27,7 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) match av.value with | ABorrow _ -> true | ALoan _ -> false - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in let aborrows, aloans = List.partition is_borrow abs.avalues in @@ -39,13 +40,13 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) let get_borrow_id (av : typed_avalue) : BorrowId.id = match av.value with | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in let get_loan_id (av : typed_avalue) : BorrowId.id = match av.value with | ALoan (AMutLoan (lid, _)) -> lid | ALoan (ASharedLoan (lids, _, _)) -> BorrowId.Set.min_elt lids - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in (* We use ordered maps to reorder the borrows and loans *) let reorder (get_bid : typed_avalue -> BorrowId.id) @@ -128,7 +129,7 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) This can happen when merging environments (note that such environments are not well-formed - they become well formed again after collapsing). *) -let collapse_ctx (loop_id : LoopId.id) +let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs option) (old_ids : ids_sets) (ctx0 : eval_ctx) : eval_ctx = (* Debug *) @@ -274,7 +275,7 @@ let collapse_ctx (loop_id : LoopId.id) ^ "\n\n- after collapse:\n" ^ eval_ctx_to_string !ctx ^ "\n\n")); (* Reorder the loans and borrows in the fresh abstractions *) - let ctx = reorder_loans_borrows_in_fresh_abs old_ids.aids !ctx in + let ctx = reorder_loans_borrows_in_fresh_abs meta old_ids.aids !ctx in log#ldebug (lazy @@ -285,7 +286,7 @@ let collapse_ctx (loop_id : LoopId.id) (* Return the new context *) ctx -let mk_collapse_ctx_merge_duplicate_funs (loop_id : LoopId.id) (ctx : eval_ctx) +let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id) (ctx : eval_ctx) : merge_duplicates_funcs = (* Rem.: the merge functions raise exceptions (that we catch). *) let module S : MatchJoinState = struct @@ -306,8 +307,8 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : LoopId.id) (ctx : eval_ctx) *) let merge_amut_borrows id ty0 child0 _ty1 child1 = (* Sanity checks *) - assert (is_aignored child0.value); - assert (is_aignored child1.value); + cassert (is_aignored child0.value) meta "Children are not [AIgnored]"; + cassert (is_aignored child1.value) meta "Children are not [AIgnored]"; (* We need to pick a type for the avalue. The types on the left and on the right may use different regions: it doesn't really matter (here, we pick @@ -325,8 +326,8 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : LoopId.id) (ctx : eval_ctx) let _ = let _, ty0, _ = ty_as_ref ty0 in let _, ty1, _ = ty_as_ref ty1 in - assert (not (ty_has_borrows ctx.type_ctx.type_infos ty0)); - assert (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) + cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) meta ""; + cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) meta "" in (* Same remarks as for [merge_amut_borrows] *) @@ -337,8 +338,8 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : LoopId.id) (ctx : eval_ctx) let merge_amut_loans id ty0 child0 _ty1 child1 = (* Sanity checks *) - assert (is_aignored child0.value); - assert (is_aignored child1.value); + cassert (is_aignored child0.value) meta "Children are not [AIgnored]"; + cassert (is_aignored child1.value) meta "Children are not [AIgnored]"; (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in let child = child0 in @@ -348,15 +349,15 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : LoopId.id) (ctx : eval_ctx) let merge_ashared_loans ids ty0 (sv0 : typed_value) child0 _ty1 (sv1 : typed_value) child1 = (* Sanity checks *) - assert (is_aignored child0.value); - assert (is_aignored child1.value); + cassert (is_aignored child0.value) meta "Children are not [AIgnored]"; + cassert (is_aignored child1.value) meta "Children are not [AIgnored]"; (* Same remarks as for [merge_amut_borrows]. This time we need to also merge the shared values. We rely on the join matcher [JM] to do so. *) - assert (not (value_has_loans_or_borrows ctx sv0.value)); - assert (not (value_has_loans_or_borrows ctx sv1.value)); + cassert (not (value_has_loans_or_borrows ctx sv0.value)) meta ""; + cassert (not (value_has_loans_or_borrows ctx sv1.value)) meta ""; let ty = ty0 in let child = child0 in let sv = M.match_typed_values ctx ctx sv0 sv1 in @@ -370,10 +371,10 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : LoopId.id) (ctx : eval_ctx) merge_ashared_loans; } -let merge_into_abstraction (loop_id : LoopId.id) (abs_kind : abs_kind) +let merge_into_abstraction (meta : Meta.meta) (loop_id : LoopId.id) (abs_kind : abs_kind) (can_end : bool) (ctx : eval_ctx) (aid0 : AbstractionId.id) (aid1 : AbstractionId.id) : eval_ctx * AbstractionId.id = - let merge_funs = mk_collapse_ctx_merge_duplicate_funs loop_id ctx in + let merge_funs = mk_collapse_ctx_merge_duplicate_funs meta loop_id ctx in merge_into_abstraction abs_kind can_end (Some merge_funs) ctx aid0 aid1 (** Collapse an environment, merging the duplicated borrows/loans. @@ -383,13 +384,13 @@ let merge_into_abstraction (loop_id : LoopId.id) (abs_kind : abs_kind) We do this because when we join environments, we may introduce duplicated loans and borrows. See the explanations for {!join_ctxs}. *) -let collapse_ctx_with_merge (loop_id : LoopId.id) (old_ids : ids_sets) +let collapse_ctx_with_merge (meta : Meta.meta) (loop_id : LoopId.id) (old_ids : ids_sets) (ctx : eval_ctx) : eval_ctx = - let merge_funs = mk_collapse_ctx_merge_duplicate_funs loop_id ctx in - try collapse_ctx loop_id (Some merge_funs) old_ids ctx - with ValueMatchFailure _ -> raise (Failure "Unexpected") + let merge_funs = mk_collapse_ctx_merge_duplicate_funs meta loop_id ctx in + try collapse_ctx meta loop_id (Some merge_funs) old_ids ctx + with ValueMatchFailure _ -> craise meta "Unexpected" -let join_ctxs (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) +let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) (ctx1 : eval_ctx) : ctx_or_update = (* Debug *) log#ldebug @@ -422,14 +423,14 @@ let join_ctxs (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) match ee with | EBinding (BVar _, _) -> (* Variables are necessarily in the prefix *) - raise (Failure "Unreachable") + craise meta "Unreachable" | EBinding (BDummy did, _) -> - assert (not (DummyVarId.Set.mem did fixed_ids.dids)) + cassert (not (DummyVarId.Set.mem did fixed_ids.dids)) meta "" | EAbs abs -> - assert (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) + cassert (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) meta "" | EFrame -> (* This should have been eliminated *) - raise (Failure "Unreachable") + craise meta "Unreachable" in List.iter check_valid env0; List.iter check_valid env1; @@ -465,7 +466,7 @@ let join_ctxs (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) are not in the prefix anymore *) if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Still in the prefix: match the values *) - assert (b0 = b1); + cassert (b0 = b1) meta "Bindings are not the same. We are not in the prefix anymore"; let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in let var = EBinding (BDummy b, v) in @@ -487,7 +488,8 @@ let join_ctxs (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) (* Variable bindings *must* be in the prefix and consequently their ids must be the same *) - assert (b0 = b1); + cassert (b0 = b1) meta "Variable bindings *must* be in the prefix and consequently their + ids must be the same"; (* Match the values *) let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in @@ -505,7 +507,7 @@ let join_ctxs (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) (* Same as for the dummy values: there are two cases *) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( (* Still in the prefix: the abstractions must be the same *) - assert (abs0 = abs1); + cassert (abs0 = abs1) meta "The abstractions are not the same"; (* Continue *) abs :: join_prefixes env0' env1') else (* Not in the prefix anymore *) @@ -520,7 +522,7 @@ let join_ctxs (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) let env0, env1 = match (env0, env1) with | EFrame :: env0, EFrame :: env1 -> (env0, env1) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in log#ldebug @@ -634,7 +636,7 @@ let refresh_abs (old_abs : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = in { ctx with env } -let loop_join_origin_with_continue_ctxs (config : config) (loop_id : LoopId.id) +let loop_join_origin_with_continue_ctxs (meta : Meta.meta) (config : config) (loop_id : LoopId.id) (fixed_ids : ids_sets) (old_ctx : eval_ctx) (ctxl : eval_ctx list) : (eval_ctx * eval_ctx list) * eval_ctx = (* # Join with the new contexts, one by one @@ -647,7 +649,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (loop_id : LoopId.id) *) let joined_ctx = ref old_ctx in let rec join_one_aux (ctx : eval_ctx) : eval_ctx = - match join_ctxs loop_id fixed_ids !joined_ctx ctx with + match join_ctxs meta loop_id fixed_ids !joined_ctx ctx with | Ok nctx -> joined_ctx := nctx; ctx @@ -659,7 +661,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (loop_id : LoopId.id) | LoansInRight bids -> InterpreterBorrows.end_borrows_no_synth config bids ctx | AbsInRight _ | AbsInLeft _ | LoanInLeft _ | LoansInLeft _ -> - raise (Failure "Unexpected") + craise meta "Unexpected" in join_one_aux ctx in @@ -677,7 +679,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (loop_id : LoopId.id) ^ eval_ctx_to_string ctx)); (* Collapse the context we want to add to the join *) - let ctx = collapse_ctx loop_id None fixed_ids ctx in + let ctx = collapse_ctx meta loop_id None fixed_ids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after collapse:\n" @@ -696,14 +698,14 @@ let loop_join_origin_with_continue_ctxs (config : config) (loop_id : LoopId.id) (* Collapse again - the join might have introduce abstractions we want to merge with the others (note that those abstractions may actually lead to borrows/loans duplications) *) - joined_ctx := collapse_ctx_with_merge loop_id fixed_ids !joined_ctx; + joined_ctx := collapse_ctx_with_merge meta loop_id fixed_ids !joined_ctx; log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after join-collapse:\n" ^ eval_ctx_to_string !joined_ctx)); (* Sanity check *) - if !Config.sanity_checks then Invariants.check_invariants !joined_ctx; + if !Config.sanity_checks then Invariants.check_invariants meta !joined_ctx; (* Return *) ctx1 in diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index dd7bd7a7..67c1155c 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -14,6 +14,7 @@ open InterpreterUtils open InterpreterBorrowsCore open InterpreterBorrows open InterpreterLoopsCore +open Errors module S = SynthesizeSymbolic (** The local logger *) @@ -1400,7 +1401,7 @@ let ctxs_are_equivalent (fixed_ids : ids_sets) (ctx0 : eval_ctx) (match_ctxs check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx0 ctx1) -let prepare_match_ctx_with_target (config : config) (loop_id : LoopId.id) +let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id : LoopId.id) (fixed_ids : ids_sets) (src_ctx : eval_ctx) : cm_fun = fun cf tgt_ctx -> (* Debug *) @@ -1599,7 +1600,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) let fixed_ids = ids_sets_empty_borrows_loans fixed_ids in let open InterpreterBorrowsCore in let lookup_shared_loan lid ctx : typed_value = - match snd (lookup_loan ek_all lid ctx) with + match snd (lookup_loan meta ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v | _ -> raise (Failure "Unreachable") diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 999b8ab0..e411db9b 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -8,6 +8,7 @@ open InterpreterUtils open InterpreterBorrowsCore open InterpreterBorrows open InterpreterExpansion +open Errors module Synth = SynthesizeSymbolic (** The local logger *) @@ -68,7 +69,7 @@ type projection_access = { TODO: use exceptions? *) -let rec access_projection (access : projection_access) (ctx : eval_ctx) +let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : eval_ctx) (* Function to (eventually) update the value we find *) (update : typed_value -> typed_value) (p : projection) (v : typed_value) : (eval_ctx * updated_read_value) path_access_result = @@ -85,10 +86,10 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) (lazy ("Not the same type:\n- nv.ty: " ^ show_ety nv.ty ^ "\n- v.ty: " ^ show_ety v.ty)); - raise - (Failure + craise + meta "Assertion failed: new value doesn't have the same type as its \ - destination")); + destination"); Ok (ctx, { read = v; updated = nv }) | pe :: p' -> ( (* Match on the projection element and the value *) @@ -101,10 +102,10 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) | ProjAdt (def_id, opt_variant_id), TAdtId def_id' -> assert (def_id = def_id'); assert (opt_variant_id = adt.variant_id) - | _ -> raise (Failure "Unreachable")); + | _ -> craise meta "Unreachable"); (* Actually project *) let fv = FieldId.nth adt.field_values field_id in - match access_projection access ctx update p' fv with + match access_projection meta access ctx update p' fv with | Error err -> Error err | Ok (ctx, res) -> (* Update the field value *) @@ -119,7 +120,7 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) assert (arity = List.length adt.field_values); let fv = FieldId.nth adt.field_values field_id in (* Project *) - match access_projection access ctx update p' fv with + match access_projection meta access ctx update p' fv with | Error err -> Error err | Ok (ctx, res) -> (* Update the field value *) @@ -146,7 +147,7 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) * it shouldn't happen due to user code, and we leverage it * when implementing box dereferencement for the concrete * interpreter *) - match access_projection access ctx update p' bv with + match access_projection meta access ctx update p' bv with | Error err -> Error err | Ok (ctx, res) -> let nv = @@ -163,18 +164,18 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) | VSharedBorrow bid -> (* Lookup the loan content, and explore from there *) if access.lookup_shared_borrows then - match lookup_loan ek bid ctx with + match lookup_loan meta ek bid ctx with | _, Concrete (VMutLoan _) -> - raise (Failure "Expected a shared loan") + craise meta "Expected a shared loan" | _, Concrete (VSharedLoan (bids, sv)) -> ( (* Explore the shared value *) - match access_projection access ctx update p' sv with + match access_projection meta access ctx update p' sv with | Error err -> Error err | Ok (ctx, res) -> (* Update the shared loan with the new value returned by {!access_projection} *) let ctx = - update_loan ek bid + update_loan meta ek bid (VSharedLoan (bids, res.updated)) ctx in @@ -190,22 +191,22 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } | AIgnoredSharedLoan _ ) ) -> - raise (Failure "Expected a shared (abstraction) loan") + craise meta "Expected a shared (abstraction) loan" | _, Abstract (ASharedLoan (bids, sv, _av)) -> ( (* Explore the shared value *) - match access_projection access ctx update p' sv with + match access_projection meta access ctx update p' sv with | Error err -> Error err | Ok (ctx, res) -> (* Relookup the child avalue *) let av = - match lookup_loan ek bid ctx with + match lookup_loan meta ek bid ctx with | _, Abstract (ASharedLoan (_, _, av)) -> av - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in (* Update the shared loan with the new value returned by {!access_projection} *) let ctx = - update_aloan ek bid + update_aloan meta ek bid (ASharedLoan (bids, res.updated, av)) ctx in @@ -215,7 +216,7 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) | VReservedMutBorrow bid -> Error (FailReservedMutBorrow bid) | VMutBorrow (bid, bv) -> if access.enter_mut_borrows then - match access_projection access ctx update p' bv with + match access_projection meta access ctx update p' bv with | Error err -> Error err | Ok (ctx, res) -> let nv = @@ -231,7 +232,7 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) to the fact that we need to reexplore the *whole* place (i.e, we mustn't ignore the current projection element *) if access.enter_shared_loans then - match access_projection access ctx update (pe :: p') sv with + match access_projection meta access ctx update (pe :: p') sv with | Error err -> Error err | Ok (ctx, res) -> let nv = @@ -245,7 +246,7 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) let v = "- v:\n" ^ show_value v in let ty = "- ty:\n" ^ show_ety ty in log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); - raise (Failure "Inconsistent projection")) + craise meta "Inconsistent projection") (** Generic function to access (read/write) the value at a given place. @@ -253,14 +254,14 @@ let rec access_projection (access : projection_access) (ctx : eval_ctx) environment, if we managed to access the place, or the precise reason why we failed. *) -let access_place (access : projection_access) +let access_place (meta : Meta.meta) (access : projection_access) (* Function to (eventually) update the value we find *) (update : typed_value -> typed_value) (p : place) (ctx : eval_ctx) : (eval_ctx * typed_value) path_access_result = (* Lookup the variable's value *) let value = ctx_lookup_var_value ctx p.var_id in (* Apply the projection *) - match access_projection access ctx update p.projection value with + match access_projection meta access ctx update p.projection value with | Error err -> Error err | Ok (ctx, res) -> (* Update the value *) @@ -300,12 +301,12 @@ let access_kind_to_projection_access (access : access_kind) : projection_access Note that we only access the value at the place, and do not check that the value is "well-formed" (for instance that it doesn't contain bottoms). *) -let try_read_place (access : access_kind) (p : place) (ctx : eval_ctx) : +let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value path_access_result = let access = access_kind_to_projection_access access in (* The update function is the identity *) let update v = v in - match access_place access update p ctx with + match access_place meta access update p ctx with | Error err -> Error err | Ok (ctx1, read_value) -> (* Note that we ignore the new environment: it should be the same as the @@ -318,31 +319,31 @@ let try_read_place (access : access_kind) (p : place) (ctx : eval_ctx) : ^ show_env ctx1.env ^ "\n\nOld environment:\n" ^ show_env ctx.env in log#serror msg; - raise (Failure "Unexpected environment update")); + craise meta "Unexpected environment update"); Ok read_value -let read_place (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value +let read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value = - match try_read_place access p ctx with - | Error e -> raise (Failure ("Unreachable: " ^ show_path_fail_kind e)) + match try_read_place meta access p ctx with + | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) | Ok v -> v (** Attempt to update the value at a given place *) -let try_write_place (access : access_kind) (p : place) (nv : typed_value) +let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : typed_value) (ctx : eval_ctx) : eval_ctx path_access_result = let access = access_kind_to_projection_access access in (* The update function substitutes the value with the new value *) let update _ = nv in - match access_place access update p ctx with + match access_place meta access update p ctx with | Error err -> Error err | Ok (ctx, _) -> (* We ignore the read value *) Ok ctx -let write_place (access : access_kind) (p : place) (nv : typed_value) +let write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : typed_value) (ctx : eval_ctx) : eval_ctx = - match try_write_place access p nv ctx with - | Error e -> raise (Failure ("Unreachable: " ^ show_path_fail_kind e)) + match try_write_place meta access p nv ctx with + | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) | Ok ctx -> ctx let compute_expanded_bottom_adt_value (ctx : eval_ctx) (def_id : TypeDeclId.id) @@ -395,7 +396,7 @@ let compute_expanded_bottom_tuple_value (field_types : ety list) : typed_value = about which variant we should project to, which is why we *can* set the variant index when writing one of its fields). *) -let expand_bottom_value_from_projection (access : access_kind) (p : place) +let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind) (p : place) (remaining_pes : int) (pe : projection_elem) (ty : ety) (ctx : eval_ctx) : eval_ctx = (* Debugging *) @@ -435,20 +436,20 @@ let expand_bottom_value_from_projection (access : access_kind) (p : place) (* Generate the field values *) compute_expanded_bottom_tuple_value types | _ -> - raise - (Failure - ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty)) + craise + meta + ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty) in (* Update the context by inserting the expanded value at the proper place *) - match try_write_place access p' nv ctx with + match try_write_place meta access p' nv ctx with | Ok ctx -> ctx - | Error _ -> raise (Failure "Unreachable") + | Error _ -> craise meta "Unreachable" -let rec update_ctx_along_read_place (config : config) (access : access_kind) +let rec update_ctx_along_read_place (meta : Meta.meta) (config : config) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Attempt to read the place: if it fails, update the environment and retry *) - match try_read_place access p ctx with + match try_read_place meta access p ctx with | Ok _ -> cf ctx | Error err -> let cc = @@ -467,17 +468,17 @@ let rec update_ctx_along_read_place (config : config) (access : access_kind) (Some (Synth.mk_mplace prefix ctx)) | FailBottom (_, _, _) -> (* We can't expand {!Bottom} values while reading them *) - raise (Failure "Found [Bottom] while reading a place") - | FailBorrow _ -> raise (Failure "Could not read a borrow") + craise meta "Found [Bottom] while reading a place" + | FailBorrow _ -> craise meta "Could not read a borrow" in - comp cc (update_ctx_along_read_place config access p) cf ctx + comp cc (update_ctx_along_read_place meta config access p) cf ctx -let rec update_ctx_along_write_place (config : config) (access : access_kind) +let rec update_ctx_along_write_place (meta : Meta.meta) (config : config) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Attempt to *read* (yes, *read*: we check the access to the place, and write to it later) the place: if it fails, update the environment and retry *) - match try_read_place access p ctx with + match try_read_place meta access p ctx with | Ok _ -> cf ctx | Error err -> (* Update the context *) @@ -494,19 +495,19 @@ let rec update_ctx_along_write_place (config : config) (access : access_kind) (* Expand the {!Bottom} value *) fun cf ctx -> let ctx = - expand_bottom_value_from_projection access p remaining_pes pe ty + expand_bottom_value_from_projection meta access p remaining_pes pe ty ctx in cf ctx - | FailBorrow _ -> raise (Failure "Could not write to a borrow") + | FailBorrow _ -> craise meta "Could not write to a borrow" in (* Retry *) - comp cc (update_ctx_along_write_place config access p) cf ctx + comp cc (update_ctx_along_write_place meta config access p) cf ctx (** Small utility used to break control-flow *) exception UpdateCtx of cm_fun -let rec end_loans_at_place (config : config) (access : access_kind) (p : place) +let rec end_loans_at_place (meta : Meta.meta) (config : config) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Iterator to explore a value and update the context whenever we find @@ -545,7 +546,7 @@ let rec end_loans_at_place (config : config) (access : access_kind) (p : place) in (* First, retrieve the value *) - let v = read_place access p ctx in + let v = read_place meta access p ctx in (* Inspect the value and update the context while doing so. If the context gets updated: perform a recursive call (many things may have been updated in the context: we need to re-read the value @@ -559,15 +560,15 @@ let rec end_loans_at_place (config : config) (access : access_kind) (p : place) with UpdateCtx cc -> (* We need to update the context: compose the caugth continuation with * a recursive call to reinspect the value *) - comp cc (end_loans_at_place config access p) cf ctx + comp cc (end_loans_at_place meta config access p) cf ctx -let drop_outer_loans_at_lplace (config : config) (p : place) : cm_fun = +let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) : cm_fun = fun cf ctx -> (* Move the current value in the place outside of this place and into * a dummy variable *) let access = Write in - let v = read_place access p ctx in - let ctx = write_place access p (mk_bottom v.ty) ctx in + let v = read_place meta access p ctx in + let ctx = write_place meta access p (mk_bottom v.ty) ctx in let dummy_id = fresh_dummy_var_id () in let ctx = ctx_push_dummy_var ctx dummy_id v in (* Auxiliary function *) @@ -587,7 +588,7 @@ let drop_outer_loans_at_lplace (config : config) (p : place) : cm_fun = match c with | LoanContent (VSharedLoan (bids, _)) -> end_borrows config bids | LoanContent (VMutLoan bid) -> end_borrow config bid - | BorrowContent _ -> raise (Failure "Unreachable") + | BorrowContent _ -> craise meta "Unreachable" in (* Retry *) comp cc drop cf ctx @@ -600,7 +601,7 @@ let drop_outer_loans_at_lplace (config : config) (p : place) : cm_fun = (* Pop *) let ctx, v = ctx_remove_dummy_var ctx dummy_id in (* Reinsert *) - let ctx = write_place access p v ctx in + let ctx = write_place meta access p v ctx in (* Sanity check *) assert (not (outer_loans_in_value v)); (* Continue *) @@ -609,7 +610,7 @@ let drop_outer_loans_at_lplace (config : config) (p : place) : cm_fun = (* Continue *) cc cf ctx -let prepare_lplace (config : config) (p : place) (cf : typed_value -> m_fun) : +let prepare_lplace (meta : Meta.meta) (config : config) (p : place) (cf : typed_value -> m_fun) : m_fun = fun ctx -> log#ldebug @@ -618,13 +619,13 @@ let prepare_lplace (config : config) (p : place) (cf : typed_value -> m_fun) : ^ "\n- Initial context:\n" ^ eval_ctx_to_string ctx)); (* Access the place *) let access = Write in - let cc = update_ctx_along_write_place config access p in + let cc = update_ctx_along_write_place meta config access p in (* End the borrows and loans, starting with the borrows *) - let cc = comp cc (drop_outer_loans_at_lplace config p) in + let cc = comp cc (drop_outer_loans_at_lplace meta config p) in (* Read the value and check it *) let read_check cf : m_fun = fun ctx -> - let v = read_place access p ctx in + let v = read_place meta access p ctx in (* Sanity checks *) assert (not (outer_loans_in_value v)); (* Continue *) diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 4dc53586..d4a237b2 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -6,12 +6,13 @@ module Assoc = AssociatedTypes open TypesUtils open InterpreterUtils open InterpreterBorrowsCore +open Errors (** The local logger *) let log = Logging.projectors_log (** [ty] shouldn't contain erased regions *) -let rec apply_proj_borrows_on_shared_borrow (ctx : eval_ctx) +let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t) (v : typed_value) (ty : rty) : abstract_shared_borrows = (* Sanity check - TODO: move those elsewhere (here we perform the check at every @@ -34,12 +35,12 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : eval_ctx) let proj_fields = List.map (fun (fv, fty) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions fv + apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions fv fty) fields_types in List.concat proj_fields - | VBottom, _ -> raise (Failure "Unreachable") + | VBottom, _ -> craise meta "Unreachable" | VBorrow bc, TRef (r, ref_ty, kind) -> (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) let bid, asb = @@ -48,28 +49,28 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : eval_ctx) | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let asb = - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions + apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions bv ref_ty in (bid, asb) | VSharedBorrow bid, RShared -> (* Lookup the shared value *) let ek = ek_all in - let sv = lookup_loan ek bid ctx in + let sv = lookup_loan meta ek bid ctx in let asb = match sv with | _, Concrete (VSharedLoan (_, sv)) | _, Abstract (ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow + apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions sv ref_ty - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in (bid, asb) | VReservedMutBorrow _, _ -> - raise - (Failure - "Can't apply a proj_borrow over a reserved mutable borrow") - | _ -> raise (Failure "Unreachable") + craise + meta + "Can't apply a proj_borrow over a reserved mutable borrow" + | _ -> craise meta "Unreachable" in let asb = (* Check if the region is in the set of projected regions (note that @@ -80,14 +81,14 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : eval_ctx) else asb in asb - | VLoan _, _ -> raise (Failure "Unreachable") + | VLoan _, _ -> craise meta "Unreachable" | VSymbolic s, _ -> (* Check that the projection doesn't contain ended regions *) - assert (not (projections_intersect s.sv_ty ctx.ended_regions ty regions)); + assert (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)); [ AsbProjReborrows (s, ty) ] - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" -let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) +let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) (ctx : eval_ctx) (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : typed_avalue = @@ -111,12 +112,12 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) let proj_fields = List.map (fun (fv, fty) -> - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions fv fty) fields_types in AAdt { variant_id = adt.variant_id; field_values = proj_fields } - | VBottom, _ -> raise (Failure "Unreachable") + | VBottom, _ -> craise meta "Unreachable" | VBorrow bc, TRef (r, ref_ty, kind) -> if (* Check if the region is in the set of projected regions (note that @@ -129,7 +130,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let bv = - apply_proj_borrows check_symbolic_no_ended ctx + apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions bv ref_ty in AMutBorrow (bid, bv) @@ -147,11 +148,11 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) *) ASharedBorrow bid | VReservedMutBorrow _, _ -> - raise - (Failure + craise + meta "Can't apply a proj_borrow over a reserved mutable \ - borrow") - | _ -> raise (Failure "Unreachable") + borrow" + | _ -> craise meta "Unreachable" in ABorrow bc else @@ -163,7 +164,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let bv = - apply_proj_borrows check_symbolic_no_ended ctx + apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions bv ref_ty in (* If the borrow id is in the ancestor's regions, we still need @@ -176,25 +177,25 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) | VSharedBorrow bid, RShared -> (* Lookup the shared value *) let ek = ek_all in - let sv = lookup_loan ek bid ctx in + let sv = lookup_loan meta ek bid ctx in let asb = match sv with | _, Concrete (VSharedLoan (_, sv)) | _, Abstract (ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow + apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions sv ref_ty - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" in AProjSharedBorrow asb | VReservedMutBorrow _, _ -> - raise - (Failure + craise + meta "Can't apply a proj_borrow over a reserved mutable \ - borrow") - | _ -> raise (Failure "Unreachable") + borrow" + | _ -> craise meta "Unreachable" in ABorrow bc - | VLoan _, _ -> raise (Failure "Unreachable") + | VLoan _, _ -> craise meta "Unreachable" | VSymbolic s, _ -> (* Check that the projection doesn't contain already ended regions, * if necessary *) @@ -211,7 +212,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " ^ RegionId.Set.to_string None rset2 ^ "\n")); - assert (not (projections_intersect ty1 rset1 ty2 rset2))); + assert (not (projections_intersect meta ty1 rset1 ty2 rset2))); ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror @@ -219,11 +220,11 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) ("apply_proj_borrows: unexpected inputs:\n- input value: " ^ typed_value_to_string ctx v ^ "\n- proj rty: " ^ ty_to_string ctx ty)); - raise (Failure "Unreachable") + craise meta "Unreachable" in { value; ty } -let symbolic_expansion_non_borrow_to_value (sv : symbolic_value) +let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) (sv : symbolic_value) (see : symbolic_expansion) : typed_value = let ty = Subst.erase_regions sv.sv_ty in let value = @@ -235,11 +236,11 @@ let symbolic_expansion_non_borrow_to_value (sv : symbolic_value) in VAdt { variant_id; field_values } | SeMutRef (_, _) | SeSharedRef (_, _) -> - raise (Failure "Unexpected symbolic reference expansion") + craise meta "Unexpected symbolic reference expansion" in { value; ty } -let symbolic_expansion_non_shared_borrow_to_value (sv : symbolic_value) +let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) (sv : symbolic_value) (see : symbolic_expansion) : typed_value = match see with | SeMutRef (bid, bv) -> @@ -248,14 +249,14 @@ let symbolic_expansion_non_shared_borrow_to_value (sv : symbolic_value) let value = VBorrow (VMutBorrow (bid, bv)) in { value; ty } | SeSharedRef (_, _) -> - raise (Failure "Unexpected symbolic shared reference expansion") - | _ -> symbolic_expansion_non_borrow_to_value sv see + craise meta "Unexpected symbolic shared reference expansion" + | _ -> symbolic_expansion_non_borrow_to_value meta sv see (** Apply (and reduce) a projector over loans to a value. TODO: detailed comments. See [apply_proj_borrows] *) -let apply_proj_loans_on_symbolic_expansion (regions : RegionId.Set.t) +let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) (see : symbolic_expansion) (original_sv_ty : rty) : typed_avalue = (* Sanity check: if we have a proj_loans over a symbolic value, it should @@ -305,7 +306,7 @@ let apply_proj_loans_on_symbolic_expansion (regions : RegionId.Set.t) else (* Not in the set: ignore *) (ALoan (AIgnoredSharedLoan child_av), ref_ty) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in { value; ty } @@ -467,7 +468,7 @@ let apply_reborrows (reborrows : (BorrowId.id * BorrowId.id) list) (* Return *) ctx -let prepare_reborrows (config : config) (allow_reborrows : bool) : +let prepare_reborrows (meta : Meta.meta) (config : config) (allow_reborrows : bool) : (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) = let reborrows : (BorrowId.id * BorrowId.id) list ref = ref [] in (* The function to generate and register fresh reborrows *) @@ -476,7 +477,7 @@ let prepare_reborrows (config : config) (allow_reborrows : bool) : let bid' = fresh_borrow_id () in reborrows := (bid, bid') :: !reborrows; bid') - else raise (Failure "Unexpected reborrow") + else craise meta "Unexpected reborrow" in (* The function to apply the reborrows in a context *) let apply_registered_reborrows (ctx : eval_ctx) : eval_ctx = @@ -491,7 +492,7 @@ let prepare_reborrows (config : config) (allow_reborrows : bool) : (fresh_reborrow, apply_registered_reborrows) (** [ty] shouldn't have erased regions *) -let apply_proj_borrows_on_input_value (config : config) (ctx : eval_ctx) +let apply_proj_borrows_on_input_value (meta : Meta.meta) (config : config) (ctx : eval_ctx) (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = assert (ty_is_rty ty); @@ -499,11 +500,11 @@ let apply_proj_borrows_on_input_value (config : config) (ctx : eval_ctx) let allow_reborrows = true in (* Prepare the reborrows *) let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows + prepare_reborrows meta config allow_reborrows in (* Apply the projector *) let av = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions + apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions v ty in (* Apply the reborrows *) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 6b9f47ce..bd6fab1a 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -11,6 +11,7 @@ open InterpreterProjectors open InterpreterExpansion open InterpreterPaths open InterpreterExpressions +open Errors module Subst = Substitute module S = SynthesizeSymbolic @@ -93,7 +94,7 @@ let push_vars (vars : (var * typed_value) list) : cm_fun = dummy variable and putting in its destination (after having checked that preparing the destination didn't introduce ⊥). *) -let assign_to_place (config : config) (rv : typed_value) (p : place) : cm_fun = +let assign_to_place (meta : Meta.meta) (config : config) (rv : typed_value) (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -118,7 +119,7 @@ let assign_to_place (config : config) (rv : typed_value) (p : place) : cm_fun = let ctx = ctx_push_dummy_var ctx dest_vid mv in (* Write to the destination *) (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) - assert (not (bottom_in_value ctx.ended_regions rv)); + cassert (not (bottom_in_value ctx.ended_regions rv)) meta "TODO: Error message"; (* Update the destination *) let ctx = write_place Write p rv ctx in (* Debug *) @@ -135,7 +136,7 @@ let assign_to_place (config : config) (rv : typed_value) (p : place) : cm_fun = comp cc move_dest cf ctx (** Evaluate an assertion, when the scrutinee is not symbolic *) -let eval_assertion_concrete (config : config) (assertion : assertion) : +let eval_assertion_concrete (meta : Meta.meta) (config : config) (assertion : assertion) : st_cm_fun = fun cf ctx -> (* There won't be any symbolic expansions: fully evaluate the operand *) @@ -147,8 +148,8 @@ let eval_assertion_concrete (config : config) (assertion : assertion) : (* Branch *) if b = assertion.expected then cf Unit ctx else cf Panic ctx | _ -> - raise - (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) + craise + meta ("Expected a boolean, got: " ^ typed_value_to_string ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -159,14 +160,14 @@ let eval_assertion_concrete (config : config) (assertion : assertion) : a call to [assert ...] then continue in the success branch (and thus expand the boolean to [true]). *) -let eval_assertion (config : config) (assertion : assertion) : st_cm_fun = +let eval_assertion (meta : Meta.meta) (config : config) (assertion : assertion) : st_cm_fun = fun cf ctx -> (* Evaluate the operand *) let eval_op = eval_operand config assertion.cond in (* Evaluate the assertion *) let eval_assert cf (v : typed_value) : m_fun = fun ctx -> - assert (v.ty = TLiteral TBool); + cassert (v.ty = TLiteral TBool) meta "TODO: Error message"; (* We make a choice here: we could completely decouple the concrete and * symbolic executions here but choose not to. In the case where we * know the concrete value of the boolean we test, we use this value @@ -175,10 +176,10 @@ let eval_assertion (config : config) (assertion : assertion) : st_cm_fun = match v.value with | VLiteral (VBool _) -> (* Delegate to the concrete evaluation function *) - eval_assertion_concrete config assertion cf ctx + eval_assertion_concrete meta config assertion cf ctx | VSymbolic sv -> - assert (config.mode = SymbolicMode); - assert (sv.sv_ty = TLiteral TBool); + cassert (config.mode = SymbolicMode) meta "TODO: Error message"; + cassert (sv.sv_ty = TLiteral TBool) meta "TODO: Error message"; (* We continue the execution as if the test had succeeded, and thus * perform the symbolic expansion: sv ~~> true. * We will of course synthesize an assertion in the generated code @@ -192,8 +193,8 @@ let eval_assertion (config : config) (assertion : assertion) : st_cm_fun = (* Add the synthesized assertion *) S.synthesize_assertion ctx v expr | _ -> - raise - (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) + craise + meta ("Expected a boolean, got: " ^ typed_value_to_string ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -209,7 +210,7 @@ let eval_assertion (config : config) (assertion : assertion) : st_cm_fun = a variant with all its fields set to {!Bottom}. For instance, something like: [Cons Bottom Bottom]. *) -let set_discriminant (config : config) (p : place) (variant_id : VariantId.id) : +let set_discriminant (meta : Meta.meta) (config : config) (p : place) (variant_id : VariantId.id) : st_cm_fun = fun cf ctx -> log#ldebug @@ -234,7 +235,7 @@ let set_discriminant (config : config) (p : place) (variant_id : VariantId.id) : a variant with all its fields set to {!Bottom} *) match av.variant_id with - | None -> raise (Failure "Found a struct value while expected an enum") + | None -> craise meta "Found a struct value while expected an enum" | Some variant_id' -> if variant_id' = variant_id then (* Nothing to do *) cf Unit ctx @@ -245,20 +246,20 @@ let set_discriminant (config : config) (p : place) (variant_id : VariantId.id) : | TAdtId def_id -> compute_expanded_bottom_adt_value ctx def_id (Some variant_id) generics - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in - assign_to_place config bottom_v p (cf Unit) ctx) + assign_to_place meta config bottom_v p (cf Unit) ctx) | TAdt ((TAdtId _ as type_id), generics), VBottom -> let bottom_v = match type_id with | TAdtId def_id -> compute_expanded_bottom_adt_value ctx def_id (Some variant_id) generics - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in - assign_to_place config bottom_v p (cf Unit) ctx + assign_to_place meta config bottom_v p (cf Unit) ctx | _, VSymbolic _ -> - assert (config.mode = SymbolicMode); + cassert (config.mode = SymbolicMode) meta "The Config mode should be SymbolicMode"; (* This is a bit annoying: in theory we should expand the symbolic value * then set the discriminant, because in the case the discriminant is * exactly the one we set, the fields are left untouched, and in the @@ -266,10 +267,10 @@ let set_discriminant (config : config) (p : place) (variant_id : VariantId.id) : * For now, we forbid setting the discriminant of a symbolic value: * setting a discriminant should only be used to initialize a value, * or reset an already initialized value, really. *) - raise (Failure "Unexpected value") - | _, (VAdt _ | VBottom) -> raise (Failure "Inconsistent state") + craise meta "Unexpected value" + | _, (VAdt _ | VBottom) -> craise meta "Inconsistent state" | _, (VLiteral _ | VBorrow _ | VLoan _) -> - raise (Failure "Unexpected value") + craise meta "Unexpected value" in (* Compose and apply *) comp cc update_value cf ctx @@ -284,15 +285,15 @@ let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) (** Small helper: compute the type of the return value for a specific instantiation of an assumed function. *) -let get_assumed_function_return_type (ctx : eval_ctx) (fid : assumed_fun_id) +let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : assumed_fun_id) (generics : generic_args) : ety = - assert (generics.trait_refs = []); + cassert (generics.trait_refs = []) meta "TODO: Error message"; (* [Box::free] has a special treatment *) match fid with | BoxFree -> - assert (generics.regions = []); - assert (List.length generics.types = 1); - assert (generics.const_generics = []); + cassert (generics.regions = []) meta "TODO: Error message"; + cassert (List.length generics.types = 1) meta "TODO: Error message"; + cassert (generics.const_generics = []) meta "TODO: Error message"; mk_unit_ty | _ -> (* Retrieve the function's signature *) @@ -319,7 +320,7 @@ let move_return_value (config : config) (pop_return_value : bool) cc (fun v ctx -> cf (Some v) ctx) ctx else cf None ctx -let pop_frame (config : config) (pop_return_value : bool) +let pop_frame (meta : Meta.meta) (config : config) (pop_return_value : bool) (cf : typed_value option -> m_fun) : m_fun = fun ctx -> (* Debug *) @@ -329,7 +330,7 @@ let pop_frame (config : config) (pop_return_value : bool) let ret_vid = VarId.zero in let rec list_locals env = match env with - | [] -> raise (Failure "Inconsistent environment") + | [] -> craise meta "Inconsistent environment" | EAbs _ :: env -> list_locals env | EBinding (BDummy _, _) :: env -> list_locals env | EBinding (BVar var, _) :: env -> @@ -353,7 +354,7 @@ let pop_frame (config : config) (pop_return_value : bool) match ret_value with | None -> () | Some ret_value -> - assert (not (bottom_in_value ctx.ended_regions ret_value))) + cassert (not (bottom_in_value ctx.ended_regions ret_value)) meta "TODO: Error message" ) in (* Drop the outer *loans* we find in the local variables *) @@ -384,7 +385,7 @@ let pop_frame (config : config) (pop_return_value : bool) * no outer loans) as dummy variables in the caller frame *) let rec pop env = match env with - | [] -> raise (Failure "Inconsistent environment") + | [] -> craise meta "Inconsistent environment" | EAbs abs :: env -> EAbs abs :: pop env | EBinding (_, v) :: env -> let vid = fresh_dummy_var_id () in @@ -401,15 +402,15 @@ let pop_frame (config : config) (pop_return_value : bool) comp cc cf_pop cf ctx (** Pop the current frame and assign the returned value to its destination. *) -let pop_frame_assign (config : config) (dest : place) : cm_fun = - let cf_pop = pop_frame config true in +let pop_frame_assign (meta : Meta.meta) (config : config) (dest : place) : cm_fun = + let cf_pop = pop_frame meta config true in let cf_assign cf ret_value : m_fun = - assign_to_place config (Option.get ret_value) dest cf + assign_to_place meta config (Option.get ret_value) dest cf in comp cf_pop cf_assign (** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_new_concrete (config : config) (generics : generic_args) : cm_fun = +let eval_box_new_concrete (meta : Meta.meta) (config : config) (generics : generic_args) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) match @@ -422,7 +423,7 @@ let eval_box_new_concrete (config : config) (generics : generic_args) : cm_fun = :: EBinding (_ret_var, _) :: EFrame :: _ ) -> (* Required type checking *) - assert (input_value.ty = boxed_ty); + cassert (input_value.ty = boxed_ty) meta "TODO: Error message"; (* Move the input value *) let cf_move = @@ -441,7 +442,7 @@ let eval_box_new_concrete (config : config) (generics : generic_args) : cm_fun = (* Move this value to the return variable *) let dest = mk_place_from_var_id VarId.zero in - let cf_assign = assign_to_place config box_v dest in + let cf_assign = assign_to_place meta config box_v dest in (* Continue *) cf_assign cf @@ -449,7 +450,7 @@ let eval_box_new_concrete (config : config) (generics : generic_args) : cm_fun = (* Compose and apply *) comp cf_move cf_create cf ctx - | _ -> raise (Failure "Inconsistent state") + | _ -> craise meta "Inconsistent state" (** Auxiliary function - see {!eval_assumed_function_call}. @@ -470,7 +471,7 @@ let eval_box_new_concrete (config : config) (generics : generic_args) : cm_fun = It thus updates the box value (by calling {!drop_value}) and updates the destination (by setting it to [()]). *) -let eval_box_free (config : config) (generics : generic_args) +let eval_box_free (meta : Meta.meta) (config : config) (generics : generic_args) (args : operand list) (dest : place) : cm_fun = fun cf ctx -> match (generics.regions, generics.types, generics.const_generics, args) with @@ -478,32 +479,33 @@ let eval_box_free (config : config) (generics : generic_args) (* Required type checking *) let input_box = InterpreterPaths.read_place Write input_box_place ctx in (let input_ty = ty_get_box input_box.ty in - assert (input_ty = boxed_ty)); + cassert (input_ty = boxed_ty)) meta "TODO: Error message"; (* Drop the value *) let cc = drop_value config input_box_place in (* Update the destination by setting it to [()] *) - let cc = comp cc (assign_to_place config mk_unit_value dest) in + let cc = comp cc (assign_to_place meta config mk_unit_value dest) in (* Continue *) cc cf ctx - | _ -> raise (Failure "Inconsistent state") + | _ -> craise meta "Inconsistent state" (** Evaluate a non-local function call in concrete mode *) -let eval_assumed_function_call_concrete (config : config) (fid : assumed_fun_id) +let eval_assumed_function_call_concrete (meta : Meta.meta) (config : config) (fid : assumed_fun_id) (call : call) : cm_fun = let args = call.args in let dest = call.dest in match call.func with | FnOpMove _ -> (* Closure case: TODO *) - raise (Failure "Closures are not supported yet") + craise meta "Closures are not supported yet" | FnOpRegular func -> ( let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - assert (generics.const_generics = []); + cassert (generics.const_generics = []) meta "The const generic vars environment + in concrete mode is not fully handled yet"; (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -512,7 +514,7 @@ let eval_assumed_function_call_concrete (config : config) (fid : assumed_fun_id) match fid with | BoxFree -> (* Degenerate case: box_free *) - eval_box_free config generics args dest + eval_box_free meta config generics args dest | _ -> (* "Normal" case: not box_free *) (* Evaluate the operands *) @@ -534,7 +536,7 @@ let eval_assumed_function_call_concrete (config : config) (fid : assumed_fun_id) (* Create and push the return variable *) let ret_vid = VarId.zero in - let ret_ty = get_assumed_function_return_type ctx fid generics in + let ret_ty = get_assumed_function_return_type meta ctx fid generics in let ret_var = mk_var ret_vid (Some "@return") ret_ty in let cc = comp cc (push_uninitialized_var ret_var) in @@ -551,20 +553,20 @@ let eval_assumed_function_call_concrete (config : config) (fid : assumed_fun_id) * access to a body. *) let cf_eval_body : cm_fun = match fid with - | BoxNew -> eval_box_new_concrete config generics + | BoxNew -> eval_box_new_concrete meta config generics | BoxFree -> (* Should have been treated above *) - raise (Failure "Unreachable") + craise meta "Unreachable" | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut -> - raise (Failure "Unimplemented") + craise meta "Unimplemented" in let cc = comp cc cf_eval_body in (* Pop the frame *) - let cc = comp cc (pop_frame_assign config dest) in + let cc = comp cc (pop_frame_assign meta config dest) in (* Continue *) cc cf ctx @@ -727,7 +729,7 @@ let create_push_abstractions_from_abs_region_groups which means that whenever we call a provided trait method, we do not refer to a trait clause but directly to the method provided in the trait declaration. *) -let eval_transparent_function_call_symbolic_inst (call : call) (ctx : eval_ctx) +let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call) (ctx : eval_ctx) : fun_id_or_trait_method_ref * generic_args @@ -738,7 +740,7 @@ let eval_transparent_function_call_symbolic_inst (call : call) (ctx : eval_ctx) match call.func with | FnOpMove _ -> (* Closure case: TODO *) - raise (Failure "Closures are not supported yet") + craise meta "Closures are not supported yet" | FnOpRegular func -> ( match func.func with | FunId (FRegular fid) -> @@ -762,7 +764,7 @@ let eval_transparent_function_call_symbolic_inst (call : call) (ctx : eval_ctx) (func.func, func.generics, None, def, regions_hierarchy, inst_sg) | FunId (FAssumed _) -> (* Unreachable: must be a transparent function *) - raise (Failure "Unreachable") + craise meta "Unreachable" | TraitMethod (trait_ref, method_name, _) -> ( log#ldebug (lazy @@ -822,7 +824,7 @@ let eval_transparent_function_call_symbolic_inst (call : call) (ctx : eval_ctx) | None -> (* If not found, lookup the methods provided by the trait *declaration* (remember: for now, we forbid overriding provided methods) *) - assert (trait_impl.provided_methods = []); + cassert (trait_impl.provided_methods = []) meta "Overriding provided methods is currently forbidden"; let trait_decl = ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id @@ -922,7 +924,7 @@ let eval_transparent_function_call_symbolic_inst (call : call) (ctx : eval_ctx) inst_sg ))) (** Evaluate a statement *) -let rec eval_statement (config : config) (st : statement) : st_cm_fun = +let rec eval_statement (meta : Meta.meta) (config : config) (st : statement) : st_cm_fun = fun cf ctx -> (* Debugging *) log#ldebug @@ -937,7 +939,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = * checking the invariants *) let cc = comp cc (greedy_expand_symbolic_values config) in (* Sanity check *) - let cc = comp cc Invariants.cf_check_invariants in + let cc = comp cc (Invariants.cf_check_invariants meta) in (* Evaluate *) let cf_eval_st cf : m_fun = @@ -953,7 +955,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = match rvalue with | Global (gid, generics) -> (* Evaluate the global *) - eval_global config p gid generics cf ctx + eval_global meta config p gid generics cf ctx | _ -> (* Evaluate the rvalue *) let cf_eval_rvalue = eval_rvalue_not_global config rvalue in @@ -966,13 +968,13 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = match res with | Error EPanic -> cf Panic ctx | Ok rv -> ( - let expr = assign_to_place config rv p (cf Unit) ctx in + let expr = assign_to_place meta config rv p (cf Unit) ctx in (* Update the synthesized AST - here we store meta-information. * We do it only in specific cases (it is not always useful, and * also it can lead to issues - for instance, if we borrow a * reserved borrow, we later can't translate it to pure values...) *) match rvalue with - | Global _ -> raise (Failure "Unreachable") + | Global _ -> craise meta "Unreachable" | Use _ | RvRef (_, (BShared | BMut | BTwoPhaseMut | BShallow)) | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> @@ -990,10 +992,10 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = comp cf_eval_rvalue cf_assign cf ctx) | FakeRead p -> eval_fake_read config p (cf Unit) ctx | SetDiscriminant (p, variant_id) -> - set_discriminant config p variant_id cf ctx + set_discriminant meta config p variant_id cf ctx | Drop p -> drop_value config p (cf Unit) ctx - | Assert assertion -> eval_assertion config assertion cf ctx - | Call call -> eval_function_call config call cf ctx + | Assert assertion -> eval_assertion meta config assertion cf ctx + | Call call -> eval_function_call meta config call cf ctx | Panic -> cf Panic ctx | Return -> cf Return ctx | Break i -> cf (Break i) ctx @@ -1001,12 +1003,12 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = | Nop -> cf Unit ctx | Sequence (st1, st2) -> (* Evaluate the first statement *) - let cf_st1 = eval_statement config st1 in + let cf_st1 = eval_statement meta config st1 in (* Evaluate the sequence *) let cf_st2 cf res = match res with (* Evaluation successful: evaluate the second statement *) - | Unit -> eval_statement config st2 cf + | Unit -> eval_statement meta config st2 cf (* Control-flow break: transmit. We enumerate the cases on purpose *) | Panic | Break _ | Continue _ | Return | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> @@ -1016,14 +1018,14 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = comp cf_st1 cf_st2 cf ctx | Loop loop_body -> InterpreterLoops.eval_loop config st.meta - (eval_statement config loop_body) + (eval_statement meta config loop_body) cf ctx - | Switch switch -> eval_switch config switch cf ctx + | Switch switch -> eval_switch meta config switch cf ctx in (* Compose and apply *) comp cc cf_eval_st cf ctx -and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) +and eval_global (meta : Meta.meta) (config : config) (dest : place) (gid : GlobalDeclId.id) (generics : generic_args) : st_cm_fun = fun cf ctx -> let global = ctx_lookup_global_decl ctx gid in @@ -1032,11 +1034,11 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) (* Treat the evaluation of the global as a call to the global body *) let func = { func = FunId (FRegular global.body); generics } in let call = { func = FnOpRegular func; args = []; dest } in - (eval_transparent_function_call_concrete config global.body call) cf ctx + (eval_transparent_function_call_concrete meta config global.body call) cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) - assert (ty_no_regions global.ty); + cassert (ty_no_regions global.ty) meta "TODO: Error message"; (* Instantiate the type *) (* There shouldn't be any reference to Self *) let tr_self : trait_instance_id = UnknownTrait __FUNCTION__ in @@ -1050,13 +1052,13 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) in let sval = mk_fresh_symbolic_value ty in let cc = - assign_to_place config (mk_typed_value_from_symbolic_value sval) dest + assign_to_place meta config (mk_typed_value_from_symbolic_value sval) dest in let e = cc (cf Unit) ctx in S.synthesize_global_eval gid generics sval e (** Evaluate a switch *) -and eval_switch (config : config) (switch : switch) : st_cm_fun = +and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_fun = fun cf ctx -> (* We evaluate the operand in two steps: * first we prepare it, then we check if its value is concrete or @@ -1081,20 +1083,20 @@ and eval_switch (config : config) (switch : switch) : st_cm_fun = (* Evaluate the if and the branch body *) let cf_branch cf : m_fun = (* Branch *) - if b then eval_statement config st1 cf - else eval_statement config st2 cf + if b then eval_statement meta config st1 cf + else eval_statement meta config st2 cf in (* Compose the continuations *) cf_branch cf ctx | VSymbolic sv -> (* Expand the symbolic boolean, and continue by evaluating * the branches *) - let cf_true : st_cm_fun = eval_statement config st1 in - let cf_false : st_cm_fun = eval_statement config st2 in + let cf_true : st_cm_fun = eval_statement meta config st1 in + let cf_false : st_cm_fun = eval_statement meta config st2 in expand_symbolic_bool config sv (S.mk_opt_place_from_op op ctx) cf_true cf_false cf ctx - | _ -> raise (Failure "Inconsistent state") + | _ -> craise meta "Inconsistent state" in (* Compose *) comp cf_eval_op cf_if cf ctx @@ -1109,11 +1111,11 @@ and eval_switch (config : config) (switch : switch) : st_cm_fun = (* Evaluate the branch *) let cf_eval_branch cf = (* Sanity check *) - assert (sv.int_ty = int_ty); + cassert (sv.int_ty = int_ty) meta "TODO: Error message"; (* Find the branch *) match List.find_opt (fun (svl, _) -> List.mem sv svl) stgts with - | None -> eval_statement config otherwise cf - | Some (_, tgt) -> eval_statement config tgt cf + | None -> eval_statement meta config otherwise cf + | Some (_, tgt) -> eval_statement meta config tgt cf in (* Compose *) cf_eval_branch cf ctx @@ -1122,7 +1124,7 @@ and eval_switch (config : config) (switch : switch) : st_cm_fun = * proper branches *) let stgts = List.map - (fun (cv, tgt_st) -> (cv, eval_statement config tgt_st)) + (fun (cv, tgt_st) -> (cv, eval_statement meta config tgt_st)) stgts in (* Several branches may be grouped together: every branch is described @@ -1136,12 +1138,12 @@ and eval_switch (config : config) (switch : switch) : st_cm_fun = stgts) in (* Translate the otherwise branch *) - let otherwise = eval_statement config otherwise in + let otherwise = eval_statement meta config otherwise in (* Expand and continue *) expand_symbolic_int config sv (S.mk_opt_place_from_op op ctx) int_ty stgts otherwise cf ctx - | _ -> raise (Failure "Inconsistent state") + | _ -> craise meta "Inconsistent state" in (* Compose *) comp cf_eval_op cf_switch cf ctx @@ -1167,9 +1169,9 @@ and eval_switch (config : config) (switch : switch) : st_cm_fun = match List.find_opt (fun (svl, _) -> List.mem dv svl) stgts with | None -> ( match otherwise with - | None -> raise (Failure "No otherwise branch") - | Some otherwise -> eval_statement config otherwise cf ctx) - | Some (_, tgt) -> eval_statement config tgt cf ctx) + | None -> craise meta "No otherwise branch" + | Some otherwise -> eval_statement meta config otherwise cf ctx) + | Some (_, tgt) -> eval_statement meta config tgt cf ctx) | VSymbolic sv -> (* Expand the symbolic value - may lead to branching *) let cf_expand = @@ -1177,8 +1179,8 @@ and eval_switch (config : config) (switch : switch) : st_cm_fun = in (* Re-evaluate the switch - the value is not symbolic anymore, which means we will go to the other branch *) - cf_expand (eval_switch config switch) cf ctx - | _ -> raise (Failure "Inconsistent state") + cf_expand (eval_switch meta config switch) cf ctx + | _ -> craise meta "Inconsistent state" in (* Compose *) comp cf_read_p cf_match cf ctx @@ -1187,54 +1189,54 @@ and eval_switch (config : config) (switch : switch) : st_cm_fun = cf_match cf ctx (** Evaluate a function call (auxiliary helper for [eval_statement]) *) -and eval_function_call (config : config) (call : call) : st_cm_fun = +and eval_function_call (meta : Meta.meta) (config : config) (call : call) : st_cm_fun = (* There are several cases: - this is a local function, in which case we execute its body - this is an assumed function, in which case there is a special treatment - this is a trait method *) match config.mode with - | ConcreteMode -> eval_function_call_concrete config call - | SymbolicMode -> eval_function_call_symbolic config call + | ConcreteMode -> eval_function_call_concrete meta config call + | SymbolicMode -> eval_function_call_symbolic meta config call -and eval_function_call_concrete (config : config) (call : call) : st_cm_fun = +and eval_function_call_concrete (meta : Meta.meta) (config : config) (call : call) : st_cm_fun = fun cf ctx -> match call.func with - | FnOpMove _ -> raise (Failure "Closures are not supported yet") + | FnOpMove _ -> craise meta "Closures are not supported yet" | FnOpRegular func -> ( match func.func with | FunId (FRegular fid) -> - eval_transparent_function_call_concrete config fid call cf ctx + eval_transparent_function_call_concrete meta config fid call cf ctx | FunId (FAssumed fid) -> (* Continue - note that we do as if the function call has been successful, * by giving {!Unit} to the continuation, because we place us in the case * where we haven't panicked. Of course, the translation needs to take the * panic case into account... *) - eval_assumed_function_call_concrete config fid call (cf Unit) ctx - | TraitMethod _ -> raise (Failure "Unimplemented")) + eval_assumed_function_call_concrete meta config fid call (cf Unit) ctx + | TraitMethod _ -> craise meta "Unimplemented") -and eval_function_call_symbolic (config : config) (call : call) : st_cm_fun = +and eval_function_call_symbolic (meta : Meta.meta) (config : config) (call : call) : st_cm_fun = match call.func with - | FnOpMove _ -> raise (Failure "Closures are not supported yet") + | FnOpMove _ -> craise meta "Closures are not supported yet" | FnOpRegular func -> ( match func.func with | FunId (FRegular _) | TraitMethod _ -> - eval_transparent_function_call_symbolic config call + eval_transparent_function_call_symbolic meta config call | FunId (FAssumed fid) -> - eval_assumed_function_call_symbolic config fid call func) + eval_assumed_function_call_symbolic meta config fid call func) (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_transparent_function_call_concrete (config : config) +and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) (fid : FunDeclId.id) (call : call) : st_cm_fun = let args = call.args in let dest = call.dest in match call.func with - | FnOpMove _ -> raise (Failure "Closures are not supported yet") + | FnOpMove _ -> craise meta "Closures are not supported yet" | FnOpRegular func -> let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - assert (generics.const_generics = []); + cassert (generics.const_generics = []) meta "The const generic vars environment in concrete mode is not fully handled yet"; fun cf ctx -> (* Retrieve the (correctly instantiated) body *) let def = ctx_lookup_fun_decl ctx fid in @@ -1242,14 +1244,14 @@ and eval_transparent_function_call_concrete (config : config) let body = match def.body with | None -> - raise - (Failure + craise + meta ("Can't evaluate a call to an opaque function: " - ^ name_to_string ctx def.name)) + ^ name_to_string ctx def.name) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) - assert (generics.trait_refs = []); + cassert (generics.trait_refs = []) meta "Traits are not supported yet TODO: error message"; (* There shouldn't be any reference to Self *) let tr_self = UnknownTrait __FUNCTION__ in let subst = @@ -1258,7 +1260,7 @@ and eval_transparent_function_call_concrete (config : config) let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - assert (List.length args = body.arg_count); + cassert (List.length args = body.arg_count) meta "TODO: Error message"; let cc = eval_operands config args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result @@ -1271,7 +1273,7 @@ and eval_transparent_function_call_concrete (config : config) let ret_var, locals = match locals with | ret_ty :: locals -> (ret_ty, locals) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in let input_locals, locals = Collections.List.split_at locals body.arg_count @@ -1294,7 +1296,7 @@ and eval_transparent_function_call_concrete (config : config) let cc = comp cc (push_uninitialized_vars locals) in (* Execute the function body *) - let cc = comp cc (eval_function_body config body_st) in + let cc = comp cc (eval_function_body meta config body_st) in (* Pop the stack frame and move the return value to its destination *) let cf_finish cf res = @@ -1303,10 +1305,10 @@ and eval_transparent_function_call_concrete (config : config) | Return -> (* Pop the stack frame, retrieve the return value, move it to * its destination and continue *) - pop_frame_assign config dest (cf Unit) + pop_frame_assign meta config dest (cf Unit) | Break _ | Continue _ | Unit | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> - raise (Failure "Unreachable") + craise meta "Unreachable" in let cc = comp cc cf_finish in @@ -1314,16 +1316,16 @@ and eval_transparent_function_call_concrete (config : config) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_transparent_function_call_symbolic (config : config) (call : call) : +and eval_transparent_function_call_symbolic (meta : Meta.meta) (config : config) (call : call) : st_cm_fun = fun cf ctx -> let func, generics, trait_method_generics, def, regions_hierarchy, inst_sg = - eval_transparent_function_call_symbolic_inst call ctx + eval_transparent_function_call_symbolic_inst meta call ctx in (* Sanity check *) - assert (List.length call.args = List.length def.signature.inputs); + cassert (List.length call.args = List.length def.signature.inputs) meta "TODO: Error message"; (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config func def.signature + eval_function_call_symbolic_from_inst_sig meta config func def.signature regions_hierarchy inst_sg generics trait_method_generics call.args call.dest cf ctx @@ -1338,7 +1340,7 @@ and eval_transparent_function_call_symbolic (config : config) (call : call) : overriding them. We treat them as regular method, which take an additional trait ref as input. *) -and eval_function_call_symbolic_from_inst_sig (config : config) +and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : config) (fid : fun_id_or_trait_method_ref) (sg : fun_sig) (regions_hierarchy : region_var_groups) (inst_sg : inst_fun_sig) (generics : generic_args) @@ -1377,20 +1379,20 @@ and eval_function_call_symbolic_from_inst_sig (config : config) let args_with_rtypes = List.combine args inst_sg.inputs in (* Check the type of the input arguments *) - assert ( + cassert ( List.for_all (fun ((arg, rty) : typed_value * rty) -> arg.ty = Subst.erase_regions rty) - args_with_rtypes); + args_with_rtypes) meta "TODO: Error message"; (* Check that the input arguments don't contain symbolic values that can't * be fed to functions (i.e., symbolic values output from function return * values and which contain borrows of borrows can't be used as function * inputs *) - assert ( + cassert ( List.for_all (fun arg -> not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) - args); + args) meta "The input argument should not contain symbolic values that can't be fed to functions TODO: error message"; (* Initialize the abstractions and push them in the context. * First, we define the function which, given an initialized, empty @@ -1429,7 +1431,7 @@ and eval_function_call_symbolic_from_inst_sig (config : config) let cc = comp cc cf_call in (* Move the return value to its destination *) - let cc = comp cc (assign_to_place config ret_value dest) in + let cc = comp cc (assign_to_place meta config ret_value dest) in (* End the abstractions which don't contain loans and don't have parent * abstractions. @@ -1450,7 +1452,7 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (* Check if it contains non-ignored loans *) && Option.is_none (InterpreterBorrowsCore - .get_first_non_ignored_aloan_in_abstraction abs)) + .get_first_non_ignored_aloan_in_abstraction meta abs)) !abs_ids in (* Check if there are abstractions to end *) @@ -1485,7 +1487,7 @@ and eval_function_call_symbolic_from_inst_sig (config : config) cc (cf Unit) ctx (** Evaluate a non-local function call in symbolic mode *) -and eval_assumed_function_call_symbolic (config : config) (fid : assumed_fun_id) +and eval_assumed_function_call_symbolic (meta : Meta.meta) (config : config) (fid : assumed_fun_id) (call : call) (func : fn_ptr) : st_cm_fun = fun cf ctx -> let generics = func.generics in @@ -1493,10 +1495,10 @@ and eval_assumed_function_call_symbolic (config : config) (fid : assumed_fun_id) let dest = call.dest in (* Sanity check: make sure the type parameters don't contain regions - * this is a current limitation of our synthesis *) - assert ( + cassert ( List.for_all (fun ty -> not (ty_has_borrows ctx.type_ctx.type_infos ty)) - generics.types); + generics.types) meta "The parameters should not contain regions TODO: error message"; (* There are two cases (and this is extremely annoying): - the function is not box_free @@ -1507,7 +1509,7 @@ and eval_assumed_function_call_symbolic (config : config) (fid : assumed_fun_id) | BoxFree -> (* Degenerate case: box_free - note that this is not really a function * call: no need to call a "synthesize_..." function *) - eval_box_free config generics args dest (cf Unit) ctx + eval_box_free meta config generics args dest (cf Unit) ctx | _ -> (* "Normal" case: not box_free *) (* In symbolic mode, the behaviour of a function call is completely defined @@ -1517,7 +1519,7 @@ and eval_assumed_function_call_symbolic (config : config) (fid : assumed_fun_id) match fid with | BoxFree -> (* Should have been treated above *) - raise (Failure "Unreachable") + craise meta "Unreachable" | _ -> let regions_hierarchy = LlbcAstUtils.FunIdMap.find (FAssumed fid) @@ -1533,14 +1535,14 @@ and eval_assumed_function_call_symbolic (config : config) (fid : assumed_fun_id) in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (FunId (FAssumed fid)) sg + eval_function_call_symbolic_from_inst_sig meta config (FunId (FAssumed fid)) sg regions_hierarchy inst_sig generics None args dest cf ctx (** Evaluate a statement seen as a function body *) -and eval_function_body (config : config) (body : statement) : st_cm_fun = +and eval_function_body (meta : Meta.meta) (config : config) (body : statement) : st_cm_fun = fun cf ctx -> log#ldebug (lazy "eval_function_body:"); - let cc = eval_statement config body in + let cc = eval_statement meta config body in let cf_finish cf res = log#ldebug (lazy "eval_function_body: cf_finish"); (* Note that we *don't* check the result ({!Panic}, {!Return}, etc.): we @@ -1549,7 +1551,7 @@ and eval_function_body (config : config) (body : statement) : st_cm_fun = * checking the invariants *) let cc = greedy_expand_symbolic_values config in (* Sanity check *) - let cc = comp_check_ctx cc Invariants.check_invariants in + let cc = comp_check_ctx cc (Invariants.check_invariants meta) in (* Continue *) cc (cf res) in diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index b87cdff7..871bf90d 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -8,6 +8,7 @@ open Cps open TypesUtils open InterpreterUtils open InterpreterBorrowsCore +open Errors (** The local logger *) let log = Logging.invariants_log @@ -47,7 +48,7 @@ type borrow_kind = BMut | BShared | BReserved - loans and borrows are correctly related - a two-phase borrow can't point to a value inside an abstraction *) -let check_loans_borrows_relation_invariant (ctx : eval_ctx) : unit = +let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Link all the borrow ids to a representant - necessary because of shared * borrows/loans *) let ids_reprs : BorrowId.id BorrowId.Map.t ref = ref BorrowId.Map.empty in @@ -183,7 +184,7 @@ let check_loans_borrows_relation_invariant (ctx : eval_ctx) : unit = ^ BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () in log#serror err; - raise (Failure err) + craise meta err in let update_info (bid : BorrowId.id) (info : borrow_info) : unit = @@ -195,7 +196,7 @@ let check_loans_borrows_relation_invariant (ctx : eval_ctx) : unit = (fun x -> match x with | Some _ -> Some info - | None -> raise (Failure "Unreachable")) + | None -> craise meta "Unreachable") !borrows_infos in borrows_infos := infos @@ -209,7 +210,7 @@ let check_loans_borrows_relation_invariant (ctx : eval_ctx) : unit = (* Check that the borrow kind is consistent *) (match (info.loan_kind, kind) with | RShared, (BShared | BReserved) | RMut, BMut -> () - | _ -> raise (Failure "Invariant not satisfied")); + | _ -> craise meta "Invariant not satisfied"); (* A reserved borrow can't point to a value inside an abstraction *) assert (kind <> BReserved || not info.loan_in_abs); (* Insert the borrow id *) @@ -366,13 +367,13 @@ let check_borrowed_values_invariant (ctx : eval_ctx) : unit = let info = { outer_borrow = false; outer_shared = false } in visitor#visit_eval_ctx info ctx -let check_literal_type (cv : literal) (ty : literal_type) : unit = +let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : unit = match (cv, ty) with | VScalar sv, TInteger int_ty -> assert (sv.int_ty = int_ty) | VBool _, TBool | VChar _, TChar -> () - | _ -> raise (Failure "Erroneous typing") + | _ -> craise meta "Erroneous typing" -let check_typing_invariant (ctx : eval_ctx) : unit = +let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (* TODO: the type of aloans doens't make sense: they have a type * of the shape [& (mut) T] where they should have type [T]... * This messes a bit the type invariant checks when checking the @@ -405,7 +406,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = assert (ty_is_ety tv.ty); (* Check the current pair (value, type) *) (match (tv.value, tv.ty) with - | VLiteral cv, TLiteral ty -> check_literal_type cv ty + | VLiteral cv, TLiteral ty -> check_literal_type meta cv ty (* ADT case *) | VAdt av, TAdt (TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of @@ -420,7 +421,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = | Some variant_id, Enum variants -> assert (VariantId.to_int variant_id < List.length variants) | None, Struct _ -> () - | _ -> raise (Failure "Erroneous typing")); + | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) let field_types = AssociatedTypes.type_decl_get_inst_norm_field_etypes ctx def @@ -469,39 +470,39 @@ let check_typing_invariant (ctx : eval_ctx) : unit = .value in assert (Z.of_int (List.length inner_values) = len) - | (TSlice | TStr), _, _, _, _ -> raise (Failure "Unexpected") - | _ -> raise (Failure "Erroneous type")) + | (TSlice | TStr), _, _, _, _ -> craise meta "Unexpected" + | _ -> craise meta "Erroneous type") | VBottom, _ -> (* Nothing to check *) () | VBorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with | VSharedBorrow bid, RShared | VReservedMutBorrow bid, RMut -> ( (* Lookup the borrowed value to check it has the proper type *) - let _, glc = lookup_loan ek_all bid ctx in + let _, glc = lookup_loan meta ek_all bid ctx in match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> assert (sv.ty = ref_ty) - | _ -> raise (Failure "Inconsistent context")) + | _ -> craise meta "Inconsistent context") | VMutBorrow (_, bv), RMut -> assert ( (* Check that the borrowed value has the proper type *) bv.ty = ref_ty) - | _ -> raise (Failure "Erroneous typing")) + | _ -> craise meta "Erroneous typing") | VLoan lc, ty -> ( match lc with | VSharedLoan (_, sv) -> assert (sv.ty = ty) | VMutLoan bid -> ( (* Lookup the borrowed value to check it has the proper type *) - let glc = lookup_borrow ek_all bid ctx in + let glc = lookup_borrow meta ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> assert (bv.ty = ty) | Abstract (AMutBorrow (_, sv)) -> assert (Substitute.erase_regions sv.ty = ty) - | _ -> raise (Failure "Inconsistent context"))) + | _ -> craise meta "Inconsistent context")) | VSymbolic sv, ty -> let ty' = Substitute.erase_regions sv.sv_ty in assert (ty' = ty) - | _ -> raise (Failure "Erroneous typing")); + | _ -> craise meta "Erroneous typing"); (* Continue exploring to inspect the subterms *) super#visit_typed_value info tv @@ -535,7 +536,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = | Some variant_id, Enum variants -> assert (VariantId.to_int variant_id < List.length variants) | None, Struct _ -> () - | _ -> raise (Failure "Erroneous typing")); + | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) let field_types = AssociatedTypes.type_decl_get_inst_norm_field_rtypes ctx def @@ -571,7 +572,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = (* Box *) | TBox, [ boxed_value ], [], [ boxed_ty ], [] -> assert (boxed_value.ty = boxed_ty) - | _ -> raise (Failure "Erroneous type")) + | _ -> craise meta "Erroneous type") | ABottom, _ -> (* Nothing to check *) () | ABorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with @@ -580,19 +581,19 @@ let check_typing_invariant (ctx : eval_ctx) : unit = assert (av.ty = ref_ty) | ASharedBorrow bid, RShared -> ( (* Lookup the borrowed value to check it has the proper type *) - let _, glc = lookup_loan ek_all bid ctx in + let _, glc = lookup_loan meta ek_all bid ctx in match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> assert (sv.ty = Substitute.erase_regions ref_ty) - | _ -> raise (Failure "Inconsistent context")) + | _ -> craise meta "Inconsistent context") | AIgnoredMutBorrow (_opt_bid, av), RMut -> assert (av.ty = ref_ty) | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, RMut ) -> assert (given_back.ty = ref_ty); assert (child.ty = ref_ty) | AProjSharedBorrow _, RShared -> () - | _ -> raise (Failure "Inconsistent context")) + | _ -> craise meta "Inconsistent context") | ALoan lc, aty -> ( match lc with | AMutLoan (bid, child_av) | AIgnoredMutLoan (Some bid, child_av) @@ -600,7 +601,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = let borrowed_aty = aloan_get_expected_child_type aty in assert (child_av.ty = borrowed_aty); (* Lookup the borrowed value to check it has the proper type *) - let glc = lookup_borrow ek_all bid ctx in + let glc = lookup_borrow meta ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> assert (bv.ty = Substitute.erase_regions borrowed_aty) @@ -608,7 +609,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = assert ( Substitute.erase_regions sv.ty = Substitute.erase_regions borrowed_aty) - | _ -> raise (Failure "Inconsistent context")) + | _ -> craise meta "Inconsistent context") | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in assert (child_av.ty = borrowed_aty) @@ -647,7 +648,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = match proj with | AProjBorrows (_sv, ty') -> assert (ty' = ty) | AEndedProjBorrows _ | AIgnoredProjBorrows -> () - | _ -> raise (Failure "Unexpected")) + | _ -> craise meta "Unexpected") given_back_ls | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()) | AIgnored, _ -> () @@ -658,7 +659,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = ^ "\n- value: " ^ typed_avalue_to_string ctx atv ^ "\n- type: " ^ ty_to_string ctx atv.ty)); - raise (Failure "Erroneous typing")); + craise meta "Erroneous typing"); (* Continue exploring to inspect the subterms *) super#visit_typed_avalue info atv end @@ -697,7 +698,7 @@ type sv_info = { - the union of the aproj_loans contains the aproj_borrows applied on the same symbolic values *) -let check_symbolic_values (ctx : eval_ctx) : unit = +let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Small utility *) let module M = SymbolicValueId.Map in let infos : sv_info M.t ref = ref M.empty in @@ -796,24 +797,24 @@ let check_symbolic_values (ctx : eval_ctx) : unit = List.iter (fun binfo -> assert ( - projection_contains info.ty loan_regions binfo.proj_ty binfo.regions)) + projection_contains meta info.ty loan_regions binfo.proj_ty binfo.regions)) info.aproj_borrows; () in M.iter check_info !infos -let check_invariants (ctx : eval_ctx) : unit = +let check_invariants (meta : Meta.meta) (ctx : eval_ctx) : unit = if !Config.sanity_checks then ( log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string ctx)); - check_loans_borrows_relation_invariant ctx; + check_loans_borrows_relation_invariant meta ctx; check_borrowed_values_invariant ctx; - check_typing_invariant ctx; - check_symbolic_values ctx) + check_typing_invariant meta ctx; + check_symbolic_values meta ctx) else log#ldebug (lazy "Not checking invariants (check is not activated)") (** Same as {!check_invariants}, but written in CPS *) -let cf_check_invariants : cm_fun = +let cf_check_invariants (meta : Meta.meta) : cm_fun = fun cf ctx -> - check_invariants ctx; + check_invariants meta ctx; cf ctx diff --git a/compiler/Main.ml b/compiler/Main.ml index e703f1a0..e4e4ce1f 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -113,7 +113,7 @@ let () = Arg.Clear lean_gen_lakefile, " Generate a default lakefile.lean (Lean only)" ); ("-print-llbc", Arg.Set print_llbc, " Print the imported LLBC"); - ("-k", Arg.Clear fail_hard, " Do not fail hard in case of error"); + ("-abort-on-error", Arg.Set fail_hard, " Fail hard (fail on first error) in case of error"); ( "-tuple-nested-proj", Arg.Set use_nested_tuple_projectors, " Use nested projectors for tuples (e.g., (0, 1).snd.fst instead of \ @@ -274,7 +274,7 @@ let () = if !test_unit_functions then Test.test_unit_functions m; (* Translate the functions *) - Aeneas.Translate.translate_crate filename dest_dir m; + Aeneas.Translate.translate_crate meta filename dest_dir m; (* Print total elapsed time *) log#linfo diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 3fa550cc..b612ab70 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -5,6 +5,7 @@ open PureUtils open InterpreterUtils open FunsAnalysis open TypesAnalysis +open Errors module T = Types module V = Values module C = Contexts @@ -395,40 +396,40 @@ let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : (* Some generic translation functions (we need to translate different "flavours" of types: forward types, backward types, etc.) *) -let rec translate_generic_args (translate_ty : T.ty -> ty) +let rec translate_generic_args (meta : Meta.meta) (translate_ty : T.ty -> ty) (generics : T.generic_args) : generic_args = (* We ignore the regions: if they didn't cause trouble for the symbolic execution, then everything's fine *) let types = List.map translate_ty generics.types in let const_generics = generics.const_generics in let trait_refs = - List.map (translate_trait_ref translate_ty) generics.trait_refs + List.map (translate_trait_ref meta translate_ty) generics.trait_refs in { types; const_generics; trait_refs } -and translate_trait_ref (translate_ty : T.ty -> ty) (tr : T.trait_ref) : +and translate_trait_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) (tr : T.trait_ref) : trait_ref = - let trait_id = translate_trait_instance_id translate_ty tr.trait_id in - let generics = translate_generic_args translate_ty tr.generics in + let trait_id = translate_trait_instance_id meta translate_ty tr.trait_id in + let generics = translate_generic_args meta translate_ty tr.generics in let trait_decl_ref = - translate_trait_decl_ref translate_ty tr.trait_decl_ref + translate_trait_decl_ref meta translate_ty tr.trait_decl_ref in { trait_id; generics; trait_decl_ref } -and translate_trait_decl_ref (translate_ty : T.ty -> ty) (tr : T.trait_decl_ref) +and translate_trait_decl_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) (tr : T.trait_decl_ref) : trait_decl_ref = - let decl_generics = translate_generic_args translate_ty tr.decl_generics in + let decl_generics = translate_generic_args meta translate_ty tr.decl_generics in { trait_decl_id = tr.trait_decl_id; decl_generics } -and translate_trait_instance_id (translate_ty : T.ty -> ty) +and translate_trait_instance_id (meta : Meta.meta) (translate_ty : T.ty -> ty) (id : T.trait_instance_id) : trait_instance_id = - let translate_trait_instance_id = translate_trait_instance_id translate_ty in + let translate_trait_instance_id = translate_trait_instance_id meta translate_ty in match id with | T.Self -> Self | TraitImpl id -> TraitImpl id | BuiltinOrAuto _ -> (* We should have eliminated those in the prepasses *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Clause id -> Clause id | ParentClause (inst_id, decl_id, clause_id) -> let inst_id = translate_trait_instance_id inst_id in @@ -436,16 +437,16 @@ and translate_trait_instance_id (translate_ty : T.ty -> ty) | ItemClause (inst_id, decl_id, item_name, clause_id) -> let inst_id = translate_trait_instance_id inst_id in ItemClause (inst_id, decl_id, item_name, clause_id) - | TraitRef tr -> TraitRef (translate_trait_ref translate_ty tr) - | FnPointer _ | Closure _ -> raise (Failure "Closures are not supported yet") - | UnknownTrait s -> raise (Failure ("Unknown trait found: " ^ s)) + | TraitRef tr -> TraitRef (translate_trait_ref meta translate_ty tr) + | FnPointer _ | Closure _ -> craise meta "Closures are not supported yet" + | UnknownTrait s -> craise meta ("Unknown trait found: " ^ s) (** Translate a signature type - TODO: factor out the different translation functions *) -let rec translate_sty (ty : T.ty) : ty = +let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = let translate = translate_sty in match ty with | T.TAdt (type_id, generics) -> ( - let generics = translate_sgeneric_args generics in + let generics = translate_sgeneric_args meta generics in match type_id with | T.TAdtId adt_id -> TAdt (TAdtId adt_id, generics) | T.TTuple -> @@ -458,81 +459,81 @@ let rec translate_sty (ty : T.ty) : ty = match generics.types with | [ ty ] -> ty | _ -> - raise - (Failure - "Box/vec/option type with incorrect number of arguments") + craise + meta + "Box/vec/option type with incorrect number of arguments" ) | T.TArray -> TAdt (TAssumed TArray, generics) | T.TSlice -> TAdt (TAssumed TSlice, generics) | T.TStr -> TAdt (TAssumed TStr, generics))) | TVar vid -> TVar vid | TLiteral ty -> TLiteral ty - | TNever -> raise (Failure "Unreachable") - | TRef (_, rty, _) -> translate rty + | TNever -> craise meta "Unreachable" + | TRef (_, rty, _) -> translate meta rty | TRawPtr (ty, rkind) -> let mut = match rkind with RMut -> Mut | RShared -> Const in - let ty = translate ty in + let ty = translate meta ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in TAdt (TAssumed (TRawPtr mut), generics) | TTraitType (trait_ref, type_name) -> - let trait_ref = translate_strait_ref trait_ref in + let trait_ref = translate_strait_ref meta trait_ref in TTraitType (trait_ref, type_name) - | TArrow _ -> raise (Failure "TODO") + | TArrow _ -> craise meta "TODO" -and translate_sgeneric_args (generics : T.generic_args) : generic_args = - translate_generic_args translate_sty generics +and translate_sgeneric_args (meta : Meta.meta) (generics : T.generic_args) : generic_args = + translate_generic_args meta (translate_sty meta) generics -and translate_strait_ref (tr : T.trait_ref) : trait_ref = - translate_trait_ref translate_sty tr +and translate_strait_ref (meta : Meta.meta) (tr : T.trait_ref) : trait_ref = + translate_trait_ref meta (translate_sty meta) tr -and translate_strait_instance_id (id : T.trait_instance_id) : trait_instance_id +and translate_strait_instance_id (meta : Meta.meta) (id : T.trait_instance_id) : trait_instance_id = - translate_trait_instance_id translate_sty id + translate_trait_instance_id meta (translate_sty meta) id -let translate_trait_clause (clause : T.trait_clause) : trait_clause = +let translate_trait_clause (meta : Meta.meta) (clause : T.trait_clause) : trait_clause = let { T.clause_id; meta = _; trait_id; clause_generics } = clause in - let generics = translate_sgeneric_args clause_generics in + let generics = translate_sgeneric_args meta clause_generics in { clause_id; trait_id; generics } -let translate_strait_type_constraint (ttc : T.trait_type_constraint) : +let translate_strait_type_constraint (meta : Meta.meta) (ttc : T.trait_type_constraint) : trait_type_constraint = let { T.trait_ref; type_name; ty } = ttc in - let trait_ref = translate_strait_ref trait_ref in - let ty = translate_sty ty in + let trait_ref = translate_strait_ref meta trait_ref in + let ty = translate_sty meta ty in { trait_ref; type_name; ty } -let translate_predicates (preds : T.predicates) : predicates = +let translate_predicates (meta : Meta.meta) (preds : T.predicates) : predicates = let trait_type_constraints = - List.map translate_strait_type_constraint preds.trait_type_constraints + List.map (translate_strait_type_constraint meta) preds.trait_type_constraints in { trait_type_constraints } -let translate_generic_params (generics : T.generic_params) : generic_params = +let translate_generic_params (meta : Meta.meta) (generics : T.generic_params) : generic_params = let { T.regions = _; types; const_generics; trait_clauses } = generics in - let trait_clauses = List.map translate_trait_clause trait_clauses in + let trait_clauses = List.map (translate_trait_clause meta) trait_clauses in { types; const_generics; trait_clauses } -let translate_field (f : T.field) : field = +let translate_field (meta : Meta.meta) (f : T.field) : field = let field_name = f.field_name in - let field_ty = translate_sty f.field_ty in + let field_ty = translate_sty meta f.field_ty in { field_name; field_ty } -let translate_fields (fl : T.field list) : field list = - List.map translate_field fl +let translate_fields (meta : Meta.meta) (fl : T.field list) : field list = + List.map (translate_field meta) fl -let translate_variant (v : T.variant) : variant = +let translate_variant (meta : Meta.meta) (v : T.variant) : variant = let variant_name = v.variant_name in - let fields = translate_fields v.fields in + let fields = translate_fields meta v.fields in { variant_name; fields } -let translate_variants (vl : T.variant list) : variant list = - List.map translate_variant vl +let translate_variants (meta : Meta.meta) (vl : T.variant list) : variant list = + List.map (translate_variant meta) vl (** Translate a type def kind from LLBC *) -let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = +let translate_type_decl_kind (meta : Meta.meta) (kind : T.type_decl_kind) : type_decl_kind = match kind with - | T.Struct fields -> Struct (translate_fields fields) - | T.Enum variants -> Enum (translate_variants variants) + | T.Struct fields -> Struct (translate_fields meta fields) + | T.Enum variants -> Enum (translate_variants meta variants) | T.Opaque -> Opaque (** Translate a type definition from LLBC @@ -540,7 +541,7 @@ let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = Remark: this is not symbolic to pure but LLBC to pure. Still, I don't see the point of moving this definition for now. *) -let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : +let translate_type_decl (meta : Meta.meta) (ctx : Contexts.decls_ctx) (def : T.type_decl) : type_decl = log#ldebug (lazy @@ -555,10 +556,10 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) assert (regions = []); - let trait_clauses = List.map translate_trait_clause trait_clauses in + let trait_clauses = List.map (translate_trait_clause meta) trait_clauses in let generics = { types; const_generics; trait_clauses } in - let kind = translate_type_decl_kind def.T.kind in - let preds = translate_predicates def.preds in + let kind = translate_type_decl_kind meta def.T.kind in + let preds = translate_predicates meta def.preds in let is_local = def.is_local in let meta = def.meta in { @@ -573,7 +574,7 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : preds; } -let translate_type_id (id : T.type_id) : type_id = +let translate_type_id (meta : Meta.meta) (id : T.type_id) : type_id = match id with | TAdtId adt_id -> TAdtId adt_id | TAssumed aty -> @@ -585,7 +586,7 @@ let translate_type_id (id : T.type_id) : type_id = | T.TBox -> (* Boxes have to be eliminated: this type id shouldn't be translated *) - raise (Failure "Unreachable") + craise meta "Unreachable" in TAssumed aty | TTuple -> TTuple @@ -598,15 +599,15 @@ let translate_type_id (id : T.type_id) : type_id = TODO: factor out the various translation functions. *) -let rec translate_fwd_ty (type_infos : type_infos) (ty : T.ty) : ty = - let translate = translate_fwd_ty type_infos in +let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) (ty : T.ty) : ty = + let translate = translate_fwd_ty meta type_infos in match ty with | T.TAdt (type_id, generics) -> ( - let t_generics = translate_fwd_generic_args type_infos generics in + let t_generics = translate_fwd_generic_args meta type_infos generics in (* Eliminate boxes and simplify tuples *) match type_id with | TAdtId _ | TAssumed (TArray | TSlice | TStr) -> - let type_id = translate_type_id type_id in + let type_id = translate_type_id meta type_id in TAdt (type_id, t_generics) | TTuple -> (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the @@ -623,12 +624,12 @@ let rec translate_fwd_ty (type_infos : type_infos) (ty : T.ty) : ty = match t_generics.types with | [ bty ] -> bty | _ -> - raise - (Failure + craise + meta "Unreachable: box/vec/option receives exactly one type \ - parameter"))) + parameter")) | TVar vid -> TVar vid - | TNever -> raise (Failure "Unreachable") + | TNever -> craise meta "Unreachable" | TLiteral lty -> TLiteral lty | TRef (_, rty, _) -> translate rty | TRawPtr (ty, rkind) -> @@ -637,32 +638,32 @@ let rec translate_fwd_ty (type_infos : type_infos) (ty : T.ty) : ty = let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in TAdt (TAssumed (TRawPtr mut), generics) | TTraitType (trait_ref, type_name) -> - let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in TTraitType (trait_ref, type_name) - | TArrow _ -> raise (Failure "TODO") + | TArrow _ -> craise meta "TODO" -and translate_fwd_generic_args (type_infos : type_infos) +and translate_fwd_generic_args (meta : Meta.meta) (type_infos : type_infos) (generics : T.generic_args) : generic_args = - translate_generic_args (translate_fwd_ty type_infos) generics + translate_generic_args meta (translate_fwd_ty meta type_infos) generics -and translate_fwd_trait_ref (type_infos : type_infos) (tr : T.trait_ref) : +and translate_fwd_trait_ref (meta : Meta.meta) (type_infos : type_infos) (tr : T.trait_ref) : trait_ref = - translate_trait_ref (translate_fwd_ty type_infos) tr + translate_trait_ref meta (translate_fwd_ty meta type_infos) tr -and translate_fwd_trait_instance_id (type_infos : type_infos) +and translate_fwd_trait_instance_id (meta : Meta.meta) (type_infos : type_infos) (id : T.trait_instance_id) : trait_instance_id = - translate_trait_instance_id (translate_fwd_ty type_infos) id + translate_trait_instance_id meta (translate_fwd_ty meta type_infos) id (** Simply calls [translate_fwd_ty] *) -let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : T.ty) : ty = +let ctx_translate_fwd_ty (meta : Meta.meta) (ctx : bs_ctx) (ty : T.ty) : ty = let type_infos = ctx.type_ctx.type_infos in - translate_fwd_ty type_infos ty + translate_fwd_ty meta type_infos ty (** Simply calls [translate_fwd_generic_args] *) -let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : T.generic_args) : +let ctx_translate_fwd_generic_args (meta : Meta.meta) (ctx : bs_ctx) (generics : T.generic_args) : generic_args = let type_infos = ctx.type_ctx.type_infos in - translate_fwd_generic_args type_infos generics + translate_fwd_generic_args meta type_infos generics (** Translate a type, when some regions may have ended. @@ -670,21 +671,21 @@ let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : T.generic_args) : [inside_mut]: are we inside a mutable borrow? *) -let rec translate_back_ty (type_infos : type_infos) +let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) (keep_region : T.region -> bool) (inside_mut : bool) (ty : T.ty) : ty option = - let translate = translate_back_ty type_infos keep_region inside_mut in + let translate = translate_back_ty meta type_infos keep_region inside_mut in (* A small helper for "leave" types *) let wrap ty = if inside_mut then Some ty else None in match ty with | T.TAdt (type_id, generics) -> ( match type_id with | TAdtId _ | TAssumed (TArray | TSlice | TStr) -> - let type_id = translate_type_id type_id in + let type_id = translate_type_id meta type_id in if inside_mut then (* We do not want to filter anything, so we translate the generics as "forward" types *) - let generics = translate_fwd_generic_args type_infos generics in + let generics = translate_fwd_generic_args meta type_infos generics in Some (TAdt (type_id, generics)) else (* If not inside a mutable reference: check if at least one @@ -695,7 +696,7 @@ let rec translate_back_ty (type_infos : type_infos) *) let types = List.filter_map translate generics.types in if types <> [] then - let generics = translate_fwd_generic_args type_infos generics in + let generics = translate_fwd_generic_args meta type_infos generics in Some (TAdt (type_id, generics)) else None | TAssumed TBox -> ( @@ -705,8 +706,8 @@ let rec translate_back_ty (type_infos : type_infos) match generics.types with | [ bty ] -> translate bty | _ -> - raise - (Failure "Unreachable: boxes receive exactly one type parameter") + craise + meta "Unreachable: boxes receive exactly one type parameter" ) | TTuple -> ( (* Tuples can contain borrows (which we eliminate) *) @@ -718,7 +719,7 @@ let rec translate_back_ty (type_infos : type_infos) * is the identity *) Some (mk_simpl_tuple_ty tys_t))) | TVar vid -> wrap (TVar vid) - | TNever -> raise (Failure "Unreachable") + | TNever -> craise meta "Unreachable" | TLiteral lty -> wrap (TLiteral lty) | TRef (r, rty, rkind) -> ( match rkind with @@ -729,7 +730,7 @@ let rec translate_back_ty (type_infos : type_infos) (* Dive in, remembering the fact that we are inside a mutable borrow *) let inside_mut = true in if keep_region r then - translate_back_ty type_infos keep_region inside_mut rty + translate_back_ty meta type_infos keep_region inside_mut rty else None) | TRawPtr _ -> (* TODO: not sure what to do here *) @@ -740,23 +741,23 @@ let rec translate_back_ty (type_infos : type_infos) if inside_mut then (* Translate the trait ref as a "forward" trait ref - we do not want to filter any type *) - let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in Some (TTraitType (trait_ref, type_name)) else None - | TArrow _ -> raise (Failure "TODO") + | TArrow _ -> craise meta "TODO" (** Simply calls [translate_back_ty] *) -let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) +let ctx_translate_back_ty (meta : Meta.meta) (ctx : bs_ctx) (keep_region : 'r -> bool) (inside_mut : bool) (ty : T.ty) : ty option = let type_infos = ctx.type_ctx.type_infos in - translate_back_ty type_infos keep_region inside_mut ty + translate_back_ty meta type_infos keep_region inside_mut ty -let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = +let mk_type_check_ctx (meta : Meta.meta) (ctx : bs_ctx) : PureTypeCheck.tc_ctx = let const_generics = T.ConstGenericVarId.Map.of_list (List.map (fun (cg : T.const_generic_var) -> - (cg.index, ctx_translate_fwd_ty ctx (T.TLiteral cg.ty))) + (cg.index, ctx_translate_fwd_ty meta ctx (T.TLiteral cg.ty))) ctx.sg.generics.const_generics) in let env = VarId.Map.empty in @@ -767,23 +768,23 @@ let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = const_generics; } -let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = - let ctx = mk_type_check_ctx ctx in +let type_check_pattern (meta : Meta.meta) (ctx : bs_ctx) (v : typed_pattern) : unit = + let ctx = mk_type_check_ctx meta ctx in let _ = PureTypeCheck.check_typed_pattern ctx v in () -let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = +let type_check_texpression (meta : Meta.meta) (ctx : bs_ctx) (e : texpression) : unit = if !Config.type_check_pure_code then - let ctx = mk_type_check_ctx ctx in + let ctx = mk_type_check_ctx meta ctx in PureTypeCheck.check_texpression ctx e -let translate_fun_id_or_trait_method_ref (ctx : bs_ctx) +let translate_fun_id_or_trait_method_ref (meta : Meta.meta) (ctx : bs_ctx) (id : A.fun_id_or_trait_method_ref) : fun_id_or_trait_method_ref = match id with | FunId fun_id -> FunId fun_id | TraitMethod (trait_ref, method_name, fun_decl_id) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in TraitMethod (trait_ref, method_name, fun_decl_id) let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) @@ -805,7 +806,7 @@ let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) that we need to call. This function may be [None] if it has to be ignored (because it does nothing). *) -let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) +let bs_ctx_register_backward_call (meta : Meta.meta) (abs : V.abs) (call_id : V.FunCallId.id) (back_id : T.RegionGroupId.id) (back_args : texpression list) (ctx : bs_ctx) : bs_ctx * texpression option = (* Insert the abstraction in the call informations *) @@ -903,7 +904,7 @@ let compute_raw_fun_effect_info (fun_infos : fun_info A.FunDeclId.Map.t) } (** TODO: not very clean. *) -let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) +let get_fun_effect_info (meta : Meta.meta) (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match lid with @@ -930,7 +931,7 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) match gid with | None -> loop_info.fwd_effect_info | Some gid -> RegionGroupId.Map.find gid loop_info.back_effect_infos) - | _ -> raise (Failure "Unreachable")) + | _ -> craise meta "Unreachable") (** Translate a function signature to a decomposed function signature. @@ -943,7 +944,7 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) We use [bid] ("backward function id") only if we split the forward and the backward functions. *) -let translate_fun_sig_with_regions_hierarchy_to_decomposed +let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) (decls_ctx : C.decls_ctx) (fun_id : A.fun_id_or_trait_method_ref) (regions_hierarchy : T.region_var_groups) (sg : A.fun_sig) (input_names : string option list) : decomposed_fun_sig = @@ -983,7 +984,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (* Compute the forward inputs *) let fwd_fuel = mk_fuel_input_ty_as_list fwd_effect_info in let fwd_inputs_no_fuel_no_state = - List.map (translate_fwd_ty type_infos) sg.inputs + List.map (translate_fwd_ty meta type_infos) sg.inputs in (* State input for the forward function *) let fwd_state_ty = @@ -995,7 +996,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed List.concat [ fwd_fuel; fwd_inputs_no_fuel_no_state; fwd_state_ty ] in (* Compute the backward output, without the effect information *) - let fwd_output = translate_fwd_ty type_infos sg.output in + let fwd_output = translate_fwd_ty meta type_infos sg.output in (* Compute the type information for the backward function *) (* Small helper to translate types for backward functions *) @@ -1017,12 +1018,12 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed let keep_region r = match r with | T.RStatic -> raise Unimplemented - | RErased -> raise (Failure "Unexpected erased region") - | RBVar _ -> raise (Failure "Unexpected bound region") + | RErased -> craise meta "Unexpected erased region" + | RBVar _ -> craise meta "Unexpected bound region" | RFVar rid -> T.RegionId.Set.mem rid gr_regions in let inside_mut = false in - translate_back_ty type_infos keep_region inside_mut ty + translate_back_ty meta type_infos keep_region inside_mut ty in let translate_back_inputs_for_gid (gid : T.RegionGroupId.id) : ty list = (* For now we don't supported nested borrows, so we check that there @@ -1190,10 +1191,10 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed in (* Generic parameters *) - let generics = translate_generic_params sg.generics in + let generics = translate_generic_params meta sg.generics in (* Return *) - let preds = translate_predicates sg.preds in + let preds = translate_predicates meta sg.preds in { generics; llbc_generics = sg.generics; @@ -1204,17 +1205,17 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed fwd_info; } -let translate_fun_sig_to_decomposed (decls_ctx : C.decls_ctx) +let translate_fun_sig_to_decomposed (meta : Meta.meta) (decls_ctx : C.decls_ctx) (fun_id : FunDeclId.id) (sg : A.fun_sig) (input_names : string option list) : decomposed_fun_sig = (* Retrieve the list of parent backward functions *) let regions_hierarchy = FunIdMap.find (FRegular fun_id) decls_ctx.fun_ctx.regions_hierarchies in - translate_fun_sig_with_regions_hierarchy_to_decomposed decls_ctx + translate_fun_sig_with_regions_hierarchy_to_decomposed meta decls_ctx (FunId (FRegular fun_id)) regions_hierarchy sg input_names -let translate_fun_sig_from_decl_to_decomposed (decls_ctx : C.decls_ctx) +let translate_fun_sig_from_decl_to_decomposed (meta : Meta.meta) (decls_ctx : C.decls_ctx) (fdef : LlbcAst.fun_decl) : decomposed_fun_sig = let input_names = match fdef.body with @@ -1225,7 +1226,7 @@ let translate_fun_sig_from_decl_to_decomposed (decls_ctx : C.decls_ctx) (LlbcAstUtils.fun_body_get_input_vars body) in let sg = - translate_fun_sig_to_decomposed decls_ctx fdef.def_id fdef.signature + translate_fun_sig_to_decomposed meta decls_ctx fdef.def_id fdef.signature input_names in log#ldebug @@ -1357,21 +1358,21 @@ let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * var * typed_pattern = (** WARNING: do not call this function directly. Call [fresh_named_var_for_symbolic_value] instead. *) -let fresh_var_llbc_ty (basename : string option) (ty : T.ty) (ctx : bs_ctx) : +let fresh_var_llbc_ty (meta : Meta.meta) (basename : string option) (ty : T.ty) (ctx : bs_ctx) : bs_ctx * var = (* Generate the fresh variable *) let id, var_counter = VarId.fresh !(ctx.var_counter) in - let ty = ctx_translate_fwd_ty ctx ty in + let ty = ctx_translate_fwd_ty meta ctx ty in let var = { id; basename; ty } in (* Update the context *) ctx.var_counter := var_counter; (* Return *) (ctx, var) -let fresh_named_var_for_symbolic_value (basename : string option) +let fresh_named_var_for_symbolic_value (meta : Meta.meta) (basename : string option) (sv : V.symbolic_value) (ctx : bs_ctx) : bs_ctx * var = (* Generate the fresh variable *) - let ctx, var = fresh_var_llbc_ty basename sv.sv_ty ctx in + let ctx, var = fresh_var_llbc_ty meta basename sv.sv_ty ctx in (* Insert in the map *) let sv_to_var = V.SymbolicValueId.Map.add_strict sv.sv_id var ctx.sv_to_var in (* Update the context *) @@ -1379,19 +1380,19 @@ let fresh_named_var_for_symbolic_value (basename : string option) (* Return *) (ctx, var) -let fresh_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : +let fresh_var_for_symbolic_value (meta : Meta.meta) (sv : V.symbolic_value) (ctx : bs_ctx) : bs_ctx * var = - fresh_named_var_for_symbolic_value None sv ctx + fresh_named_var_for_symbolic_value meta None sv ctx -let fresh_vars_for_symbolic_values (svl : V.symbolic_value list) (ctx : bs_ctx) +let fresh_vars_for_symbolic_values (meta : Meta.meta) (svl : V.symbolic_value list) (ctx : bs_ctx) : bs_ctx * var list = - List.fold_left_map (fun ctx sv -> fresh_var_for_symbolic_value sv ctx) ctx svl + List.fold_left_map (fun ctx sv -> fresh_var_for_symbolic_value meta sv ctx) ctx svl -let fresh_named_vars_for_symbolic_values +let fresh_named_vars_for_symbolic_values (meta : Meta.meta) (svl : (string option * V.symbolic_value) list) (ctx : bs_ctx) : bs_ctx * var list = List.fold_left_map - (fun ctx (name, sv) -> fresh_named_var_for_symbolic_value name sv ctx) + (fun ctx (name, sv) -> fresh_named_var_for_symbolic_value meta name sv ctx) ctx svl (** This generates a fresh variable **which is not to be linked to any symbolic value** *) @@ -1469,22 +1470,22 @@ let fresh_back_vars_for_current_fun (ctx : bs_ctx) fresh_opt_vars back_vars ctx (** IMPORTANT: do not use this one directly, but rather {!symbolic_value_to_texpression} *) -let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = +let lookup_var_for_symbolic_value (meta : Meta.meta) (sv : V.symbolic_value) (ctx : bs_ctx) : var = match V.SymbolicValueId.Map.find_opt sv.sv_id ctx.sv_to_var with | Some v -> v | None -> - raise - (Failure + craise + meta ("Could not find var for symbolic value: " - ^ V.SymbolicValueId.to_string sv.sv_id)) + ^ V.SymbolicValueId.to_string sv.sv_id) (** Peel boxes as long as the value is of the form [Box] *) -let rec unbox_typed_value (v : V.typed_value) : V.typed_value = +let rec unbox_typed_value (meta : Meta.meta) (v : V.typed_value) : V.typed_value = match (v.value, v.ty) with | V.VAdt av, T.TAdt (T.TAssumed T.TBox, _) -> ( match av.field_values with - | [ bv ] -> unbox_typed_value bv - | _ -> raise (Failure "Unreachable")) + | [ bv ] -> unbox_typed_value meta bv + | _ -> craise meta "Unreachable") | _ -> v (** Translate a symbolic value. @@ -1493,15 +1494,15 @@ let rec unbox_typed_value (v : V.typed_value) : V.typed_value = of (translated) type unit, it is important that we do not lookup variables in case the symbolic value has type unit. *) -let symbolic_value_to_texpression (ctx : bs_ctx) (sv : V.symbolic_value) : +let symbolic_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (sv : V.symbolic_value) : texpression = (* Translate the type *) - let ty = ctx_translate_fwd_ty ctx sv.sv_ty in + let ty = ctx_translate_fwd_ty meta ctx sv.sv_ty in (* If the type is unit, directly return unit *) if ty_is_unit ty then mk_unit_rvalue else (* Otherwise lookup the variable *) - let var = lookup_var_for_symbolic_value sv ctx in + let var = lookup_var_for_symbolic_value meta sv ctx in mk_texpression_from_var var (** Translate a typed value. @@ -1520,13 +1521,13 @@ let symbolic_value_to_texpression (ctx : bs_ctx) (sv : V.symbolic_value) : - end abstraction - return *) -let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) +let rec typed_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_ctx) (v : V.typed_value) : texpression = (* We need to ignore boxes *) - let v = unbox_typed_value v in - let translate = typed_value_to_texpression ctx ectx in + let v = unbox_typed_value meta v in + let translate = typed_value_to_texpression meta ctx ectx in (* Translate the type *) - let ty = ctx_translate_fwd_ty ctx v.ty in + let ty = ctx_translate_fwd_ty meta ctx v.ty in (* Translate the value *) let value = match v.value with @@ -1554,27 +1555,27 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) let cons = { e = cons_e; ty = cons_ty } in (* Apply the constructor *) mk_apps cons field_values) - | VBottom -> raise (Failure "Unreachable") + | VBottom -> craise meta "Unreachable" | VLoan lc -> ( match lc with | VSharedLoan (_, v) -> translate v - | VMutLoan _ -> raise (Failure "Unreachable")) + | VMutLoan _ -> craise meta "Unreachable") | VBorrow bc -> ( match bc with | VSharedBorrow bid -> (* Lookup the shared value in the context, and continue *) - let sv = InterpreterBorrowsCore.lookup_shared_value ectx bid in + let sv = InterpreterBorrowsCore.lookup_shared_value meta ectx bid in translate sv | VReservedMutBorrow bid -> (* Same as for shared borrows. However, note that we use reserved borrows * only in *meta-data*: a value *actually used* in the translation can't come * from an unpromoted reserved borrow *) - let sv = InterpreterBorrowsCore.lookup_shared_value ectx bid in + let sv = InterpreterBorrowsCore.lookup_shared_value meta ectx bid in translate sv | VMutBorrow (_, v) -> (* Borrows are the identity in the extraction *) translate v) - | VSymbolic sv -> symbolic_value_to_texpression ctx sv + | VSymbolic sv -> symbolic_value_to_texpression meta ctx sv in (* Debugging *) log#ldebug @@ -1584,7 +1585,7 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) ^ "\n- translated expression:\n" ^ texpression_to_string ctx value)); (* Sanity check *) - type_check_texpression ctx value; + type_check_texpression meta ctx value; (* Return *) value @@ -1603,9 +1604,9 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) ^^ ]} *) -let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) +let rec typed_avalue_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_ctx) (av : V.typed_avalue) : texpression option = - let translate = typed_avalue_to_consumed ctx ectx in + let translate = typed_avalue_to_consumed meta ctx ectx in let value = match av.value with | AAdt adt_v -> ( @@ -1625,27 +1626,27 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) * [mk_simpl_tuple_rvalue] is the identity *) let rv = mk_simpl_tuple_texpression field_values in Some rv) - | ABottom -> raise (Failure "Unreachable") - | ALoan lc -> aloan_content_to_consumed ctx ectx lc - | ABorrow bc -> aborrow_content_to_consumed ctx bc - | ASymbolic aproj -> aproj_to_consumed ctx aproj + | ABottom -> craise meta "Unreachable" + | ALoan lc -> aloan_content_to_consumed meta ctx ectx lc + | ABorrow bc -> aborrow_content_to_consumed meta ctx bc + | ASymbolic aproj -> aproj_to_consumed meta ctx aproj | AIgnored -> None in (* Sanity check - Rk.: we do this at every recursive call, which is a bit * expansive... *) (match value with | None -> () - | Some value -> type_check_texpression ctx value); + | Some value -> type_check_texpression meta ctx value); (* Return *) value -and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) +and aloan_content_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_ctx) (lc : V.aloan_content) : texpression option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> raise (Failure "Unreachable") + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> (* Return the meta-value *) - Some (typed_value_to_texpression ctx ectx given_back_meta) + Some (typed_value_to_texpression meta ctx ectx given_back_meta) | AEndedSharedLoan (_, _) -> (* We don't dive into shared loans: there is nothing to give back * inside (note that there could be a mutable borrow in the shared @@ -1654,7 +1655,7 @@ and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) None | AIgnoredMutLoan (_, _) -> (* There can be *inner* not ended mutable loans, but not outer ones *) - raise (Failure "Unreachable") + craise meta "Unreachable" | AEndedIgnoredMutLoan _ -> (* This happens with nested borrows: we need to dive in *) raise Unimplemented @@ -1662,11 +1663,11 @@ and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (* Ignore *) None -and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : +and aborrow_content_to_consumed (meta : Meta.meta) (_ctx : bs_ctx) (bc : V.aborrow_content) : texpression option = match bc with | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - raise (Failure "Unreachable") + craise meta "Unreachable" | AEndedMutBorrow (_, _) -> (* We collect consumed values: ignore *) None @@ -1677,31 +1678,31 @@ and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : (* Ignore *) None -and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = +and aproj_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (aproj : V.aproj) : texpression option = match aproj with | V.AEndedProjLoans (msv, []) -> (* The symbolic value was left unchanged *) - Some (symbolic_value_to_texpression ctx msv) + Some (symbolic_value_to_texpression meta ctx msv) | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> assert (child_aproj = AIgnoredProjBorrows); (* The symbolic value was updated *) - Some (symbolic_value_to_texpression ctx mnv) + Some (symbolic_value_to_texpression meta ctx mnv) | V.AEndedProjLoans (_, _) -> (* The symbolic value was updated, and the given back values come from sevearl * abstractions *) raise Unimplemented | AEndedProjBorrows _ -> (* We consider consumed values *) None | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - raise (Failure "Unreachable") + craise meta "Unreachable" (** Convert the abstraction values in an abstraction to consumed values. See [typed_avalue_to_consumed]. *) -let abs_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (abs : V.abs) : +let abs_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_ctx) (abs : V.abs) : texpression list = log#ldebug (lazy ("abs_to_consumed:\n" ^ abs_to_string ctx abs)); - List.filter_map (typed_avalue_to_consumed ctx ectx) abs.avalues + List.filter_map (typed_avalue_to_consumed meta ctx ectx) abs.avalues let translate_mprojection_elem (pe : E.projection_elem) : mprojection_elem option = @@ -1736,7 +1737,7 @@ let translate_opt_mplace (p : S.mplace option) : mplace option = [mp]: it is possible to provide some meta-place information, to guide the heuristics which later find pretty names for the variables. *) -let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) +let rec typed_avalue_to_given_back (meta : Meta.meta) (mp : mplace option) (av : V.typed_avalue) (ctx : bs_ctx) : bs_ctx * typed_pattern option = let ctx, value = match av.value with @@ -1748,7 +1749,7 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) let mp = None in let ctx, field_values = List.fold_left_map - (fun ctx fv -> typed_avalue_to_given_back mp fv ctx) + (fun ctx fv -> typed_avalue_to_given_back meta mp fv ctx) ctx adt_v.field_values in let field_values = List.filter_map (fun x -> x) field_values in @@ -1770,29 +1771,29 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) * is the identity *) let lv = mk_simpl_tuple_pattern field_values in (ctx, Some lv)) - | ABottom -> raise (Failure "Unreachable") - | ALoan lc -> aloan_content_to_given_back mp lc ctx - | ABorrow bc -> aborrow_content_to_given_back mp bc ctx - | ASymbolic aproj -> aproj_to_given_back mp aproj ctx + | ABottom -> craise meta "Unreachable" + | ALoan lc -> aloan_content_to_given_back meta mp lc ctx + | ABorrow bc -> aborrow_content_to_given_back meta mp bc ctx + | ASymbolic aproj -> aproj_to_given_back meta mp aproj ctx | AIgnored -> (ctx, None) in (* Sanity check - Rk.: we do this at every recursive call, which is a bit * expansive... *) - (match value with None -> () | Some value -> type_check_pattern ctx value); + (match value with None -> () | Some value -> type_check_pattern meta ctx value); (* Return *) (ctx, value) -and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) +and aloan_content_to_given_back (meta : Meta.meta) (_mp : mplace option) (lc : V.aloan_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> raise (Failure "Unreachable") + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } | AEndedSharedLoan (_, _) -> (* We consider given back values, and thus ignore those *) (ctx, None) | AIgnoredMutLoan (_, _) -> (* There can be *inner* not ended mutable loans, but not outer ones *) - raise (Failure "Unreachable") + craise meta "Unreachable" | AEndedIgnoredMutLoan _ -> (* This happens with nested borrows: we need to dive in *) raise Unimplemented @@ -1800,14 +1801,14 @@ and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) (* Ignore *) (ctx, None) -and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) +and aborrow_content_to_given_back (meta : Meta.meta) (mp : mplace option) (bc : V.aborrow_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match bc with | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - raise (Failure "Unreachable") + craise meta "Unreachable" | AEndedMutBorrow (msv, _) -> (* Return the meta-symbolic-value *) - let ctx, var = fresh_var_for_symbolic_value msv ctx in + let ctx, var = fresh_var_for_symbolic_value meta msv ctx in (ctx, Some (mk_typed_pattern_from_var var mp)) | AEndedIgnoredMutBorrow _ -> (* This happens with nested borrows: we need to dive in *) @@ -1816,7 +1817,7 @@ and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) (* Ignore *) (ctx, None) -and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : +and aproj_to_given_back (meta : Meta.meta) (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match aproj with | V.AEndedProjLoans (_, child_projs) -> @@ -1829,16 +1830,16 @@ and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : (ctx, None) | AEndedProjBorrows mv -> (* Return the meta-value *) - let ctx, var = fresh_var_for_symbolic_value mv ctx in + let ctx, var = fresh_var_for_symbolic_value meta mv ctx in (ctx, Some (mk_typed_pattern_from_var var mp)) | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - raise (Failure "Unreachable") + craise meta "Unreachable" (** Convert the abstraction values in an abstraction to given back values. See [typed_avalue_to_given_back]. *) -let abs_to_given_back (mpl : mplace option list option) (abs : V.abs) +let abs_to_given_back (meta : Meta.meta) (mpl : mplace option list option) (abs : V.abs) (ctx : bs_ctx) : bs_ctx * typed_pattern list = let avalues = match mpl with @@ -1847,17 +1848,17 @@ let abs_to_given_back (mpl : mplace option list option) (abs : V.abs) in let ctx, values = List.fold_left_map - (fun ctx (mp, av) -> typed_avalue_to_given_back mp av ctx) + (fun ctx (mp, av) -> typed_avalue_to_given_back meta mp av ctx) ctx avalues in let values = List.filter_map (fun x -> x) values in (ctx, values) (** Simply calls [abs_to_given_back] *) -let abs_to_given_back_no_mp (abs : V.abs) (ctx : bs_ctx) : +let abs_to_given_back_no_mp (meta : Meta.meta) (abs : V.abs) (ctx : bs_ctx) : bs_ctx * typed_pattern list = let mpl = List.map (fun _ -> None) abs.avalues in - abs_to_given_back (Some mpl) abs ctx + abs_to_given_back meta (Some mpl) abs ctx (** Return the ordered list of the (transitive) parents of a given abstraction. @@ -1916,38 +1917,38 @@ let eval_ctx_to_symbolic_assignments_info (ctx : bs_ctx) (* Return the computed information *) !info -let rec translate_expression (e : S.expression) (ctx : bs_ctx) : texpression = +let rec translate_expression (metadata : Meta.meta) (e : S.expression) (ctx : bs_ctx) : texpression = match e with | S.Return (ectx, opt_v) -> (* We reached a return. Remark: we can't get there if we are inside a loop. *) - translate_return ectx opt_v ctx + translate_return metadata ectx opt_v ctx | ReturnWithLoop (loop_id, is_continue) -> (* We reached a return and are inside a loop. *) translate_return_with_loop loop_id is_continue ctx | Panic -> translate_panic ctx - | FunCall (call, e) -> translate_function_call call e ctx - | EndAbstraction (ectx, abs, e) -> translate_end_abstraction ectx abs e ctx + | FunCall (call, e) -> translate_function_call metadata call e ctx + | EndAbstraction (ectx, abs, e) -> translate_end_abstraction metadata ectx abs e ctx | EvalGlobal (gid, generics, sv, e) -> - translate_global_eval gid generics sv e ctx - | Assertion (ectx, v, e) -> translate_assertion ectx v e ctx - | Expansion (p, sv, exp) -> translate_expansion p sv exp ctx + translate_global_eval metadata gid generics sv e ctx + | Assertion (ectx, v, e) -> translate_assertion metadata ectx v e ctx + | Expansion (p, sv, exp) -> translate_expansion metadata p sv exp ctx | IntroSymbolic (ectx, p, sv, v, e) -> - translate_intro_symbolic ectx p sv v e ctx - | Meta (meta, e) -> translate_emeta meta e ctx + translate_intro_symbolic metadata ectx p sv v e ctx + | Meta (meta, e) -> translate_emeta metadata meta e ctx | ForwardEnd (ectx, loop_input_values, e, back_e) -> (* Translate the end of a function, or the end of a loop. The case where we (re-)enter a loop is handled here. *) - translate_forward_end ectx loop_input_values e back_e ctx - | Loop loop -> translate_loop loop ctx + translate_forward_end metadata ectx loop_input_values e back_e ctx + | Loop loop -> translate_loop metadata loop ctx and translate_panic (ctx : bs_ctx) : texpression = (* Here we use the function return type - note that it is ok because * we don't match on panics which happen inside the function body - * but it won't be true anymore once we translate individual blocks *) - (* If we use a state monad, we need to add a lambda for the state variable *) + (* If we use a state modune partie nad, we need to add a lambda for the state variable *) (* Note that only forward functions return a state *) let effect_info = ctx_get_effect_info ctx in (* TODO: we should use a [Fail] function *) @@ -1997,7 +1998,7 @@ and translate_panic (ctx : bs_ctx) : texpression = Remark: in case we merge the forward/backward functions, we introduce those in [translate_forward_end]. *) -and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) +and translate_return (meta : Meta.meta) (ectx : C.eval_ctx) (opt_v : V.typed_value option) (ctx : bs_ctx) : texpression = (* There are two cases: - either we reach the return of a forward function or a forward loop body, @@ -2011,7 +2012,7 @@ and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) | None -> (* Forward function *) let v = Option.get opt_v in - typed_value_to_texpression ctx ectx v + typed_value_to_texpression meta ctx ectx v | Some _ -> (* Backward function *) (* Sanity check *) @@ -2084,7 +2085,7 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) (* Wrap in a result - TODO: check effect_info.can_fail to not always wrap *) mk_emeta (Tag "return_with_loop") (mk_result_return_texpression output) -and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : +and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression) (ctx : bs_ctx) : texpression = log#ldebug (lazy @@ -2093,9 +2094,9 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : ^ "\n\n- call.generics:\n" ^ ctx_generic_args_to_string ctx call.generics)); (* Translate the function call *) - let generics = ctx_translate_fwd_generic_args ctx call.generics in + let generics = ctx_translate_fwd_generic_args meta ctx call.generics in let args = - let args = List.map (typed_value_to_texpression ctx call.ctx) call.args in + let args = List.map (typed_value_to_texpression meta ctx call.ctx) call.args in let args_mplaces = List.map translate_opt_mplace call.args_places in List.map (fun (arg, mp) -> mk_opt_mplace_texpression mp arg) @@ -2108,11 +2109,11 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : match call.call_id with | S.Fun (fid, call_id) -> (* Regular function call *) - let fid_t = translate_fun_id_or_trait_method_ref ctx fid in + let fid_t = translate_fun_id_or_trait_method_ref meta ctx fid in let func = Fun (FromLlbc (fid_t, None)) in (* Retrieve the effect information about this function (can fail, * takes a state as input, etc.) *) - let effect_info = get_fun_effect_info ctx fid None None in + let effect_info = get_fun_effect_info meta ctx fid None None in (* Depending on the function effects: - add the fuel - add the state input argument @@ -2133,7 +2134,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let sg = Option.get call.sg in let decls_ctx = ctx.decls_ctx in let dsg = - translate_fun_sig_with_regions_hierarchy_to_decomposed decls_ctx fid + translate_fun_sig_with_regions_hierarchy_to_decomposed meta decls_ctx fid call.regions_hierarchy sg (List.map (fun _ -> None) sg.inputs) in @@ -2144,10 +2145,10 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : | None -> (UnknownTrait __FUNCTION__, generics) | Some (all_generics, tr_self) -> let all_generics = - ctx_translate_fwd_generic_args ctx all_generics + ctx_translate_fwd_generic_args meta ctx all_generics in let tr_self = - translate_fwd_trait_instance_id ctx.type_ctx.type_infos + translate_fwd_trait_instance_id meta ctx.type_ctx.type_infos tr_self in (tr_self, all_generics) @@ -2179,7 +2180,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : | PeIdent (s, _) -> s | PeImpl _ -> (* We shouldn't get there *) - raise (Failure "Unexpected")) + craise meta "Unexpected") in name ^ "_back" in @@ -2225,7 +2226,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : (ctx, dsg.fwd_info.ignore_output, Some back_funs_map, back_funs) in (* Compute the pattern for the destination *) - let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in let dest = (* Here there is something subtle: as we might ignore the output @@ -2262,7 +2263,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : is_rec = false; } in - let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop Not, effect_info, args, dest) | S.Unop E.Neg -> ( @@ -2280,10 +2281,10 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : is_rec = false; } in - let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Neg int_ty), effect_info, args, dest) - | _ -> raise (Failure "Unreachable")) + | _ -> craise meta "Unreachable") | S.Unop (E.Cast cast_kind) -> ( match cast_kind with | CastScalar (src_ty, tgt_ty) -> @@ -2297,10 +2298,10 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : is_rec = false; } in - let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, dest) - | CastFnPtr _ -> raise (Failure "TODO: function casts")) + | CastFnPtr _ -> craise meta "TODO: function casts") | S.Binop binop -> ( match args with | [ arg0; arg1 ] -> @@ -2319,10 +2320,10 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : is_rec = false; } in - let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Binop (binop, int_ty0), effect_info, args, dest) - | _ -> raise (Failure "Unreachable")) + | _ -> craise meta "Unreachable") in let func = { id = FunOrOp fun_id; generics } in let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in @@ -2333,11 +2334,11 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let func = { e = Qualif func; ty = func_ty } in let call = mk_apps func args in (* Translate the next expression *) - let next_e = translate_expression e ctx in + let next_e = translate_expression meta e ctx in (* Put together *) mk_let effect_info.can_fail dest_v call next_e -and translate_end_abstraction (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) : texpression = log#ldebug (lazy @@ -2345,15 +2346,15 @@ and translate_end_abstraction (ectx : C.eval_ctx) (abs : V.abs) ^ V.show_abs_kind abs.kind)); match abs.kind with | V.SynthInput rg_id -> - translate_end_abstraction_synth_input ectx abs e ctx rg_id + translate_end_abstraction_synth_input meta ectx abs e ctx rg_id | V.FunCall (call_id, rg_id) -> - translate_end_abstraction_fun_call ectx abs e ctx call_id rg_id - | V.SynthRet rg_id -> translate_end_abstraction_synth_ret ectx abs e ctx rg_id + translate_end_abstraction_fun_call meta ectx abs e ctx call_id rg_id + | V.SynthRet rg_id -> translate_end_abstraction_synth_ret meta ectx abs e ctx rg_id | V.Loop (loop_id, rg_id, abs_kind) -> - translate_end_abstraction_loop ectx abs e ctx loop_id rg_id abs_kind - | V.Identity -> translate_end_abstraction_identity ectx abs e ctx + translate_end_abstraction_loop meta ectx abs e ctx loop_id rg_id abs_kind + | V.Identity -> translate_end_abstraction_identity meta ectx abs e ctx -and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_synth_input (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) (rg_id : T.RegionGroupId.id) : texpression = log#ldebug @@ -2403,7 +2404,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) in (* Get the list of values consumed by the abstraction upon ending *) - let consumed_values = abs_to_consumed ctx ectx abs in + let consumed_values = abs_to_consumed meta ctx ectx abs in log#ldebug (lazy @@ -2428,7 +2429,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) variables_values; (* Translate the next expression *) - let next_e = translate_expression e ctx in + let next_e = translate_expression meta e ctx in (* Generate the assignemnts *) let monadic = false in List.fold_right @@ -2436,7 +2437,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) mk_let monadic (mk_typed_pattern_from_var var None) value e) variables_values next_e -and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_fun_call (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) (call_id : V.FunCallId.id) (rg_id : T.RegionGroupId.id) : texpression = let call_info = V.FunCallId.Map.find call_id ctx.calls in @@ -2446,12 +2447,12 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) | S.Fun (fun_id, _) -> fun_id | Unop _ | Binop _ -> (* Those don't have backward functions *) - raise (Failure "Unreachable") + craise meta "Unreachable" in let effect_info = get_fun_effect_info ctx fun_id None (Some rg_id) in (* Retrieve the values consumed upon ending the loans inside this * abstraction: those give us the remaining input values *) - let back_inputs = abs_to_consumed ctx ectx abs in + let back_inputs = abs_to_consumed meta ctx ectx abs in (* If the function is stateful: * - add the state input argument * - generate a fresh state variable for the returned state @@ -2471,7 +2472,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) let output_mpl = List.append (List.map translate_opt_mplace call.args_places) [ None ] in - let ctx, outputs = abs_to_given_back (Some output_mpl) abs ctx in + let ctx, outputs = abs_to_given_back meta (Some output_mpl) abs ctx in (* Group the output values together: first the updated inputs *) let output = mk_simpl_tuple_pattern outputs in (* Add the returned state if the function is stateful *) @@ -2483,10 +2484,10 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) (* Retrieve the function id, and register the function call in the context if necessary.Arith_status *) let ctx, func = - bs_ctx_register_backward_call abs call_id rg_id back_inputs ctx + bs_ctx_register_backward_call meta abs call_id rg_id back_inputs ctx in (* Translate the next expression *) - let next_e = translate_expression e ctx in + let next_e = translate_expression meta e ctx in (* Put everything together *) let inputs = back_inputs in let args_mplaces = List.map (fun _ -> None) inputs in @@ -2511,21 +2512,21 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) let call = mk_apps func args in mk_let effect_info.can_fail output call next_e -and translate_end_abstraction_identity (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_identity (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) : texpression = (* We simply check that the abstraction only contains shared borrows/loans, and translate the next expression *) (* We can do this simply by checking that it consumes and gives back nothing *) - let inputs = abs_to_consumed ctx ectx abs in - let ctx, outputs = abs_to_given_back None abs ctx in + let inputs = abs_to_consumed meta ctx ectx abs in + let ctx, outputs = abs_to_given_back meta None abs ctx in assert (inputs = []); assert (outputs = []); (* Translate the next expression *) - translate_expression e ctx + translate_expression meta e ctx -and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_synth_ret (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) (rg_id : T.RegionGroupId.id) : texpression = (* If we end the abstraction which consumed the return value of the function @@ -2561,13 +2562,13 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) let inputs = T.RegionGroupId.Map.find rg_id ctx.backward_inputs_no_state in (* Retrieve the values consumed upon ending the loans inside this * abstraction: as there are no nested borrows, there should be none. *) - let consumed = abs_to_consumed ctx ectx abs in + let consumed = abs_to_consumed meta ctx ectx abs in assert (consumed = []); (* Retrieve the values given back upon ending this abstraction - note that * we don't provide meta-place information, because those assignments will * be inlined anyway... *) log#ldebug (lazy ("abs: " ^ abs_to_string ctx abs)); - let ctx, given_back = abs_to_given_back_no_mp abs ctx in + let ctx, given_back = abs_to_given_back_no_mp meta abs ctx in (* Link the inputs to those given back values - note that this also * checks we have the same number of values, of course *) let given_back_inputs = List.combine given_back inputs in @@ -2583,7 +2584,7 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) assert (given_back.ty = input.ty)) given_back_inputs; (* Translate the next expression *) - let next_e = translate_expression e ctx in + let next_e = translate_expression meta e ctx in (* Generate the assignments *) let monadic = false in List.fold_right @@ -2591,7 +2592,7 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) mk_let monadic given_back (mk_texpression_from_var input_var) e) given_back_inputs next_e -and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_loop (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) (loop_id : V.LoopId.id) (rg_id : T.RegionGroupId.id option) (abs_kind : V.loop_abs_kind) : texpression = @@ -2604,13 +2605,13 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) match abs_kind with | V.LoopSynthInput -> (* Actually the same case as [SynthInput] *) - translate_end_abstraction_synth_input ectx abs e ctx rg_id + translate_end_abstraction_synth_input meta ectx abs e ctx rg_id | V.LoopCall -> ( (* We need to introduce a call to the backward function corresponding to a forward call which happened earlier *) let fun_id = E.FRegular ctx.fun_decl.def_id in let effect_info = - get_fun_effect_info ctx (FunId fun_id) (Some vloop_id) (Some rg_id) + get_fun_effect_info meta ctx (FunId fun_id) (Some vloop_id) (Some rg_id) in let loop_info = LoopId.Map.find loop_id ctx.loops in (* Retrieve the additional backward inputs. Note that those are actually @@ -2636,7 +2637,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (* Concatenate all the inputs *) let inputs = List.concat [ back_inputs; back_state ] in (* Retrieve the values given back by this function *) - let ctx, outputs = abs_to_given_back None abs ctx in + let ctx, outputs = abs_to_given_back meta None abs ctx in (* Group the output values together: first the updated inputs *) let output = mk_simpl_tuple_pattern outputs in (* Add the returned state if the function is stateful *) @@ -2646,7 +2647,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) | Some nstate -> mk_simpl_tuple_pattern [ nstate; output ] in (* Translate the next expression *) - let next_e = translate_expression e ctx in + let next_e = translate_expression meta e ctx in (* Put everything together *) let args_mplaces = List.map (fun _ -> None) inputs in let args = @@ -2683,7 +2684,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) *) let next_e = if ctx.inside_loop then - let consumed_values = abs_to_consumed ctx ectx abs in + let consumed_values = abs_to_consumed meta ctx ectx abs in let var_values = List.combine outputs consumed_values in let var_values = List.filter_map @@ -2701,23 +2702,23 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (* Create the let-binding *) mk_let effect_info.can_fail output call next_e) -and translate_global_eval (gid : A.GlobalDeclId.id) (generics : T.generic_args) +and translate_global_eval (meta : Meta.meta) (gid : A.GlobalDeclId.id) (generics : T.generic_args) (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) : texpression = - let ctx, var = fresh_var_for_symbolic_value sval ctx in + let ctx, var = fresh_var_for_symbolic_value meta sval ctx in let decl = A.GlobalDeclId.Map.find gid ctx.global_ctx.llbc_global_decls in let generics = ctx_translate_fwd_generic_args ctx generics in let global_expr = { id = Global gid; generics } in (* We use translate_fwd_ty to translate the global type *) - let ty = ctx_translate_fwd_ty ctx decl.ty in + let ty = ctx_translate_fwd_ty meta ctx decl.ty in let gval = { e = Qualif global_expr; ty } in - let e = translate_expression e ctx in + let e = translate_expression meta e ctx in mk_let false (mk_typed_pattern_from_var var None) gval e -and translate_assertion (ectx : C.eval_ctx) (v : V.typed_value) +and translate_assertion (meta : Meta.meta) (ectx : C.eval_ctx) (v : V.typed_value) (e : S.expression) (ctx : bs_ctx) : texpression = - let next_e = translate_expression e ctx in + let next_e = translate_expression meta e ctx in let monadic = true in - let v = typed_value_to_texpression ctx ectx v in + let v = typed_value_to_texpression meta ctx ectx v in let args = [ v ] in let func = { id = FunOrOp (Fun (Pure Assert)); generics = empty_generic_args } @@ -2727,10 +2728,10 @@ and translate_assertion (ectx : C.eval_ctx) (v : V.typed_value) let assertion = mk_apps func args in mk_let monadic (mk_dummy_pattern mk_unit_ty) assertion next_e -and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) +and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symbolic_value) (exp : S.expansion) (ctx : bs_ctx) : texpression = (* Translate the scrutinee *) - let scrutinee = symbolic_value_to_texpression ctx sv in + let scrutinee = symbolic_value_to_texpression meta ctx sv in let scrutinee_mplace = translate_opt_mplace p in (* Translate the branches *) match exp with @@ -2739,12 +2740,12 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) | V.SeLiteral _ -> (* We do not *register* symbolic expansions to literal values in the symbolic ADT *) - raise (Failure "Unreachable") + craise meta "Unreachable" | SeMutRef (_, nsv) | SeSharedRef (_, nsv) -> (* The (mut/shared) borrow type is extracted to identity: we thus simply introduce an reassignment *) - let ctx, var = fresh_var_for_symbolic_value nsv ctx in - let next_e = translate_expression e ctx in + let ctx, var = fresh_var_for_symbolic_value meta nsv ctx in + let next_e = translate_expression meta e ctx in let monadic = false in mk_let monadic (mk_typed_pattern_from_var var None) @@ -2752,11 +2753,11 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) next_e | SeAdt _ -> (* Should be in the [ExpandAdt] case *) - raise (Failure "Unreachable")) + craise meta "Unreachable") | ExpandAdt branches -> ( (* We don't do the same thing if there is a branching or not *) match branches with - | [] -> raise (Failure "Unreachable") + | [] -> craise meta "Unreachable" | [ (variant_id, svl, branch) ] when not (TypesUtils.ty_is_custom_adt sv.V.sv_ty @@ -2768,19 +2769,19 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) we *ignore* this branch (and go to the next one) if the ADT is a custom adt, and [always_deconstruct_adts_with_matches] is true. *) - translate_ExpandAdt_one_branch sv scrutinee scrutinee_mplace + translate_ExpandAdt_one_branch meta sv scrutinee scrutinee_mplace variant_id svl branch ctx | branches -> let translate_branch (variant_id : T.VariantId.id option) (svl : V.symbolic_value list) (branch : S.expression) : match_branch = - let ctx, vars = fresh_vars_for_symbolic_values svl ctx in + let ctx, vars = fresh_vars_for_symbolic_values meta svl ctx in let vars = List.map (fun x -> mk_typed_pattern_from_var x None) vars in let pat_ty = scrutinee.ty in let pat = mk_adt_pattern pat_ty variant_id vars in - let branch = translate_expression branch ctx in + let branch = translate_expression meta branch ctx in { pat; branch } in let branches = @@ -2801,8 +2802,8 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) | ExpandBool (true_e, false_e) -> (* We don't need to update the context: we don't introduce any new values/variables *) - let true_e = translate_expression true_e ctx in - let false_e = translate_expression false_e ctx in + let true_e = translate_expression meta true_e ctx in + let false_e = translate_expression meta false_e ctx in let e = Switch ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, @@ -2822,12 +2823,12 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) match_branch = (* We don't need to update the context: we don't introduce any new values/variables *) - let branch = translate_expression branch_e ctx in + let branch = translate_expression meta branch_e ctx in let pat = mk_typed_pattern_from_literal (VScalar v) in { pat; branch } in let branches = List.map translate_branch branches in - let otherwise = translate_expression otherwise ctx in + let otherwise = translate_expression meta otherwise ctx in let pat_ty = TLiteral (TInteger int_ty) in let otherwise_pat : typed_pattern = { value = PatDummy; ty = pat_ty } in let otherwise : match_branch = @@ -2867,15 +2868,15 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) as inductives, in which case it is not always possible to use a notation for the field projections. *) -and translate_ExpandAdt_one_branch (sv : V.symbolic_value) +and translate_ExpandAdt_one_branch (meta : Meta.meta) (sv : V.symbolic_value) (scrutinee : texpression) (scrutinee_mplace : mplace option) (variant_id : variant_id option) (svl : V.symbolic_value list) (branch : S.expression) (ctx : bs_ctx) : texpression = (* TODO: always introduce a match, and use micro-passes to turn the the match into a let? *) let type_id, _ = TypesUtils.ty_as_adt sv.V.sv_ty in - let ctx, vars = fresh_vars_for_symbolic_values svl ctx in - let branch = translate_expression branch ctx in + let ctx, vars = fresh_vars_for_symbolic_values meta svl ctx in + let branch = translate_expression meta branch ctx in match type_id with | TAdtId adt_id -> (* Detect if this is an enumeration or not *) @@ -2942,7 +2943,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) | TAssumed TBox -> (* There should be exactly one variable *) let var = - match vars with [ v ] -> v | _ -> raise (Failure "Unreachable") + match vars with [ v ] -> v | _ -> craise meta "Unreachable" in (* We simply introduce an assignment - the box type is the * identity when extracted ([box a = a]) *) @@ -2956,9 +2957,9 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number * of fields!) *) - raise (Failure "Attempt to expand a non-expandable value") + craise meta "Attempt to expand a non-expandable value" -and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) +and translate_intro_symbolic (meta : Meta.meta) (ectx : C.eval_ctx) (p : S.mplace option) (sv : V.symbolic_value) (v : S.value_aggregate) (e : S.expression) (ctx : bs_ctx) : texpression = log#ldebug @@ -2968,10 +2969,10 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) let mplace = translate_opt_mplace p in (* Introduce a fresh variable for the symbolic value. *) - let ctx, var = fresh_var_for_symbolic_value sv ctx in + let ctx, var = fresh_var_for_symbolic_value meta sv ctx in (* Translate the next expression *) - let next_e = translate_expression e ctx in + let next_e = translate_expression meta e ctx in (* Translate the value: there are several cases, depending on whether this is a "regular" let-binding, an array aggregate, a const generic or @@ -2979,12 +2980,12 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) *) let v = match v with - | VaSingleValue v -> typed_value_to_texpression ctx ectx v + | VaSingleValue v -> typed_value_to_texpression meta ctx ectx v | VaArray values -> (* We use a struct update to encode the array aggregate, in order to preserve the structure and allow generating code of the shape `[x0, ...., xn]` *) - let values = List.map (typed_value_to_texpression ctx ectx) values in + let values = List.map (typed_value_to_texpression meta ctx ectx) values in let values = FieldId.mapi (fun fid v -> (fid, v)) values in let su : struct_update = { struct_id = TAssumed TArray; init = None; updates = values } @@ -3004,7 +3005,7 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) let var = mk_typed_pattern_from_var var mplace in mk_let monadic var v next_e -and translate_forward_end (ectx : C.eval_ctx) +and translate_forward_end (meta : Meta.meta) (ectx : C.eval_ctx) (loop_input_values : V.typed_value S.symbolic_value_id_map option) (fwd_e : S.expression) (back_e : S.expression S.region_group_id_map) (ctx : bs_ctx) : texpression = @@ -3061,7 +3062,7 @@ and translate_forward_end (ectx : C.eval_ctx) in (ctx, e, finish) in - let e = translate_expression e ctx in + let e = translate_expression meta e ctx in finish e in @@ -3215,13 +3216,13 @@ and translate_forward_end (ectx : C.eval_ctx) loop_info.input_svl in let args = - List.map (typed_value_to_texpression ctx ectx) loop_input_values + List.map (typed_value_to_texpression meta ctx ectx) loop_input_values in let org_args = args in (* Lookup the effect info for the loop function *) let fid = E.FRegular ctx.fun_decl.def_id in - let effect_info = get_fun_effect_info ctx (FunId fid) None ctx.bid in + let effect_info = get_fun_effect_info meta ctx (FunId fid) None ctx.bid in (* Introduce a fresh output value for the forward function *) let ctx, fwd_output, output_pat = @@ -3341,7 +3342,7 @@ and translate_forward_end (ectx : C.eval_ctx) *) mk_emeta_symbolic_assignments loop_info.input_vars org_args e -and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = +and translate_loop (meta : Meta.meta) (loop : S.loop) (ctx : bs_ctx) : texpression = let loop_id = V.LoopId.Map.find loop.loop_id ctx.loop_ids_map in (* Translate the loop inputs - some inputs are symbolic values already @@ -3368,7 +3369,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (Print.list_to_string (ty_to_string ctx)) loop.rg_to_given_back_tys ^ "\n")); - let ctx, _ = fresh_vars_for_symbolic_values svl ctx in + let ctx, _ = fresh_vars_for_symbolic_values meta svl ctx in ctx in @@ -3398,7 +3399,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = List.map (fun ty -> assert (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)); - ctx_translate_fwd_ty !ctx ty) + ctx_translate_fwd_ty meta !ctx ty) tys) loop.rg_to_given_back_tys in @@ -3525,7 +3526,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* Update the context to translate the function end *) let ctx_end = { ctx with loop_id = Some loop_id } in - let fun_end = translate_expression loop.end_expr ctx_end in + let fun_end = translate_expression meta loop.end_expr ctx_end in (* Update the context for the loop body *) let ctx_loop = { ctx_end with inside_loop = true } in @@ -3536,7 +3537,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = in (* Translate the loop body *) - let loop_body = translate_expression loop.loop_expr ctx_loop in + let loop_body = translate_expression meta loop.loop_expr ctx_loop in (* Create the loop node and return *) let loop = @@ -3557,14 +3558,14 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = let ty = fun_end.ty in { e = loop; ty } -and translate_emeta (meta : S.emeta) (e : S.expression) (ctx : bs_ctx) : +and translate_emeta (metadata : Meta.meta) (meta : S.emeta) (e : S.expression) (ctx : bs_ctx) : texpression = - let next_e = translate_expression e ctx in + let next_e = translate_expression metadata e ctx in let meta = match meta with | S.Assignment (ectx, lp, rv, rp) -> let lp = translate_mplace lp in - let rv = typed_value_to_texpression ctx ectx rv in + let rv = typed_value_to_texpression metadata ctx ectx rv in let rp = translate_opt_mplace rp in Some (Assignment (lp, rv, rp)) | S.Snapshot ectx -> @@ -3663,7 +3664,7 @@ let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) (* We should have checked the command line arguments before *) raise (Failure "Unexpected") -let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = +let translate_fun_decl (meta : Meta.meta) (ctx : bs_ctx) (body : S.expression option) : fun_decl = (* Translate *) let def = ctx.fun_decl in assert (ctx.bid = None); @@ -3685,9 +3686,9 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = | None -> None | Some body -> let effect_info = - get_fun_effect_info ctx (FunId (FRegular def_id)) None None + get_fun_effect_info meta ctx (FunId (FRegular def_id)) None None in - let body = translate_expression body ctx in + let body = translate_expression meta body ctx in (* Add a match over the fuel, if necessary *) let body = if function_decreases_fuel effect_info then @@ -3695,7 +3696,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = else body in (* Sanity check *) - type_check_texpression ctx body; + type_check_texpression meta ctx body; (* Introduce the fuel parameter, if necessary *) let fuel = if function_uses_fuel effect_info then @@ -3770,11 +3771,11 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (* return *) def -let translate_type_decls (ctx : Contexts.decls_ctx) : type_decl list = - List.map (translate_type_decl ctx) +let translate_type_decls (meta : Meta.meta) (ctx : Contexts.decls_ctx) : type_decl list = + List.map (translate_type_decl meta ctx) (TypeDeclId.Map.values ctx.type_ctx.type_decls) -let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) +let translate_trait_decl (metadata : Meta.meta) (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) : trait_decl = let { def_id; @@ -3797,20 +3798,20 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) (Print.Contexts.decls_ctx_to_fmt_env ctx) llbc_name in - let generics = translate_generic_params llbc_generics in - let preds = translate_predicates preds in - let parent_clauses = List.map translate_trait_clause llbc_parent_clauses in + let generics = translate_generic_params metadata llbc_generics in + let preds = translate_predicates metadata preds in + let parent_clauses = List.map (translate_trait_clause metadata) llbc_parent_clauses in let consts = List.map - (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) + (fun (name, (ty, id)) -> (name, (translate_fwd_ty metadata type_infos ty, id))) consts in let types = List.map (fun (name, (trait_clauses, ty)) -> ( name, - ( List.map translate_trait_clause trait_clauses, - Option.map (translate_fwd_ty type_infos) ty ) )) + ( List.map (translate_trait_clause metadata) trait_clauses, + Option.map (translate_fwd_ty metadata type_infos) ty ) )) types in { @@ -3830,7 +3831,7 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) provided_methods; } -let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) +let translate_trait_impl (metadata : Meta.meta) (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) : trait_impl = let { A.def_id; @@ -3850,27 +3851,27 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) in let type_infos = ctx.type_ctx.type_infos in let impl_trait = - translate_trait_decl_ref (translate_fwd_ty type_infos) llbc_impl_trait + translate_trait_decl_ref metadata (translate_fwd_ty metadata type_infos) llbc_impl_trait in let name = Print.Types.name_to_string (Print.Contexts.decls_ctx_to_fmt_env ctx) llbc_name in - let generics = translate_generic_params llbc_generics in - let preds = translate_predicates preds in - let parent_trait_refs = List.map translate_strait_ref parent_trait_refs in + let generics = translate_generic_params metadata llbc_generics in + let preds = translate_predicates metadata preds in + let parent_trait_refs = List.map (translate_strait_ref metadata) parent_trait_refs in let consts = List.map - (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) + (fun (name, (ty, id)) -> (name, (translate_fwd_ty metadata type_infos ty, id))) consts in let types = List.map (fun (name, (trait_refs, ty)) -> ( name, - ( List.map (translate_fwd_trait_ref type_infos) trait_refs, - translate_fwd_ty type_infos ty ) )) + ( List.map (translate_fwd_trait_ref metadata type_infos) trait_refs, + translate_fwd_ty metadata type_infos ty ) )) types in { diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 9af3c71b..04aadafe 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -3,6 +3,7 @@ open Types open Values open LlbcAst open Contexts +open Errors module SA = SymbolicAst module Micro = PureMicroPasses open TranslateCore @@ -40,7 +41,7 @@ let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : fun_decl) : of backward functions, we also provide names for the outputs. TODO: maybe we should introduce a record for this. *) -let translate_function_to_pure (trans_ctx : trans_ctx) +let translate_function_to_pure (meta : Meta.meta) (trans_ctx : trans_ctx) (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fun_dsigs : Pure.decomposed_fun_sig FunDeclId.Map.t) (fdef : fun_decl) : pure_fun_translation_no_loops = @@ -175,7 +176,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) SymbolicToPure.fresh_named_vars_for_symbolic_values input_svs ctx in { ctx with forward_inputs } - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in (* Add the backward inputs *) @@ -194,7 +195,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) | Some (_, ast) -> SymbolicToPure.translate_fun_decl ctx (Some ast) (* TODO: factor out the return type *) -let translate_crate_to_pure (crate : crate) : +let translate_crate_to_pure (meta : Meta.meta) (crate : crate) : trans_ctx * Pure.type_decl list * pure_fun_translation list @@ -207,7 +208,7 @@ let translate_crate_to_pure (crate : crate) : let trans_ctx = compute_contexts crate in (* Translate all the type definitions *) - let type_decls = SymbolicToPure.translate_type_decls trans_ctx in + let type_decls = SymbolicToPure.translate_type_decls meta trans_ctx in (* Compute the type definition map *) let type_decls_map = @@ -221,7 +222,7 @@ let translate_crate_to_pure (crate : crate) : (List.map (fun (fdef : LlbcAst.fun_decl) -> ( fdef.def_id, - SymbolicToPure.translate_fun_sig_from_decl_to_decomposed trans_ctx + SymbolicToPure.translate_fun_sig_from_decl_to_decomposed meta trans_ctx fdef )) (FunDeclId.Map.values crate.fun_decls)) in @@ -229,21 +230,21 @@ let translate_crate_to_pure (crate : crate) : (* Translate all the *transparent* functions *) let pure_translations = List.map - (translate_function_to_pure trans_ctx type_decls_map fun_dsigs) + (translate_function_to_pure meta trans_ctx type_decls_map fun_dsigs) (FunDeclId.Map.values crate.fun_decls) in (* Translate the trait declarations *) let trait_decls = List.map - (SymbolicToPure.translate_trait_decl trans_ctx) + (SymbolicToPure.translate_trait_decl meta trans_ctx) (TraitDeclId.Map.values trans_ctx.trait_decls_ctx.trait_decls) in (* Translate the trait implementations *) let trait_impls = List.map - (SymbolicToPure.translate_trait_impl trans_ctx) + (SymbolicToPure.translate_trait_impl meta trans_ctx) (TraitImplId.Map.values trans_ctx.trait_impls_ctx.trait_impls) in @@ -351,9 +352,9 @@ let export_type (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) [is_rec]: [true] if the types are recursive. Necessarily [true] if there is > 1 type to extract. *) -let export_types_group (fmt : Format.formatter) (config : gen_config) +let export_types_group (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (is_rec : bool) (ids : Pure.TypeDeclId.id list) : unit = - assert (ids <> []); + cassert (ids <> []) meta "TODO: Error message"; let export_type = export_type fmt config ctx in let ids_set = Pure.TypeDeclId.Set.of_list ids in let export_type_decl kind id = export_type ids_set kind id true false in @@ -395,11 +396,11 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) if List.exists (fun b -> b) builtin then (* Sanity check *) - assert (List.for_all (fun b -> b) builtin) + cassert (List.for_all (fun b -> b) builtin) meta "TODO: Error message" else if List.exists dont_extract defs then (* Check if we have to ignore declarations *) (* Sanity check *) - assert (List.for_all dont_extract defs) + cassert (List.for_all dont_extract defs) meta "TODO: Error message" else ( (* Extract the type declarations. @@ -441,13 +442,14 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) TODO: check correct behavior with opaque globals. *) -let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) +let export_global (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (id : GlobalDeclId.id) : unit = let global_decls = ctx.trans_ctx.global_ctx.global_decls in let global = GlobalDeclId.Map.find id global_decls in let trans = FunDeclId.Map.find global.body ctx.trans_funs in - assert (trans.loops = []); - let body = trans.f in + assert (trans.fwd.loops = []); + assert (trans.backs = []); + let body = trans.fwd.f in let is_opaque = Option.is_none body.Pure.body in (* Check if we extract the global *) @@ -491,7 +493,7 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) Rem.: this function doesn't check [config.extract_fun_decls]: it should have been checked by the caller. *) -let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) +let export_functions_group_scc (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (is_rec : bool) (decls : Pure.fun_decl list) : unit = (* Utility to check a function has a decrease clause *) let has_decreases_clause (def : Pure.fun_decl) : bool = @@ -502,7 +504,7 @@ let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) (* Extract the function declarations *) (* Check if the functions are mutually recursive *) let is_mut_rec = List.length decls > 1 in - assert ((not is_mut_rec) || is_rec); + cassert ((not is_mut_rec) || is_rec) meta "TODO: Error message"; let decls_length = List.length decls in (* We open and close the declaration group with [{start, end}_fun_decl_group]. @@ -566,7 +568,7 @@ let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) In case of (non-mutually) recursive functions, we use a simple procedure to check if the forward and backward functions are mutually recursive. *) -let export_functions_group (fmt : Format.formatter) (config : gen_config) +let export_functions_group (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (pure_ls : pure_fun_translation list) : unit = (* Check if the definition are builtin - if yes they must be ignored. Note that if one definition in the group is builtin, then all the @@ -582,7 +584,7 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) if List.exists (fun b -> b) builtin then (* Sanity check *) - assert (List.for_all (fun b -> b) builtin) + cassert (List.for_all (fun b -> b) builtin) meta "TODO: Error message" else (* Utility to check a function has a decrease clause *) let has_decreases_clause (def : Pure.fun_decl) : bool = @@ -614,11 +616,11 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) | FStar -> Extract.extract_template_fstar_decreases_clause ctx fmt decl | Coq -> - raise - (Failure "Coq doesn't have decreases/termination clauses") + craise + meta "Coq doesn't have decreases/termination clauses" | HOL4 -> - raise - (Failure "HOL4 doesn't have decreases/termination clauses") + craise + meta "HOL4 doesn't have decreases/termination clauses" in extract_decrease f.f; List.iter extract_decrease f.loops) @@ -637,7 +639,7 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) (* Extract the subgroups *) let export_subgroup (is_rec : bool) (decls : Pure.fun_decl list) : unit = - export_functions_group_scc fmt config ctx is_rec decls + export_functions_group_scc meta fmt config ctx is_rec decls in List.iter (fun (is_rec, decls) -> export_subgroup is_rec decls) subgroups); @@ -692,16 +694,16 @@ let export_trait_impl (fmt : Format.formatter) (_config : gen_config) split the definitions between different files (or not), we can control what is precisely extracted. *) -let extract_definitions (fmt : Format.formatter) (config : gen_config) +let extract_definitions (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) : unit = (* Export the definition groups to the file, in the proper order. - [extract_decl]: extract the type declaration (if not filtered) - [extract_extra_info]: extra the extra type information (e.g., the [Arguments] information in Coq). *) - let export_functions_group = export_functions_group fmt config ctx in - let export_global = export_global fmt config ctx in - let export_types_group = export_types_group fmt config ctx in + let export_functions_group = export_functions_group meta fmt config ctx in + let export_global = export_global meta fmt config ctx in + let export_types_group = export_types_group meta fmt config ctx in let export_trait_decl_group id = export_trait_decl fmt config ctx id true false in @@ -783,7 +785,7 @@ type extract_file_info = { custom_includes : string list; } -let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) +let extract_file (meta : Meta.meta) (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) : unit = (* Open the file and create the formatter *) let out = open_out fi.filename in @@ -883,7 +885,7 @@ let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) Format.pp_open_vbox fmt 0; (* Extract the definitions *) - extract_definitions fmt config ctx; + extract_definitions meta fmt config ctx; (* Close the box and end the formatting *) Format.pp_close_box fmt (); @@ -903,11 +905,11 @@ let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) close_out out (** Translate a crate and write the synthesized code to an output file. *) -let translate_crate (filename : string) (dest_dir : string) (crate : crate) : +let translate_crate (meta : Meta.meta) (filename : string) (dest_dir : string) (crate : crate) : unit = (* Translate the module to the pure AST *) let trans_ctx, trans_types, trans_funs, trans_trait_decls, trans_trait_impls = - translate_crate_to_pure crate + translate_crate_to_pure meta crate in (* Initialize the names map by registering the keywords used in the @@ -1036,7 +1038,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : match Filename.chop_suffix_opt ~suffix:".llbc" filename with | None -> (* Note that we already checked the suffix upon opening the file *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Some filename -> (* Retrieve the file basename *) let basename = Filename.basename filename in @@ -1078,7 +1080,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : let ( ^^ ) = Filename.concat in if !Config.split_files then mkdir_if (dest_dir ^^ crate_name); if needs_clauses_module then ( - assert !Config.split_files; + cassert !Config.split_files meta "TODO: Error message"; mkdir_if (dest_dir ^^ crate_name ^^ "Clauses"))); (* Copy the "Primitives" file, if necessary *) @@ -1228,7 +1230,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = []; } in - extract_file opaque_config ctx file_info; + extract_file meta opaque_config ctx file_info; (* Return the additional dependencies *) [ opaque_imported_module ]) else [] @@ -1269,7 +1271,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = opaque_types_module; } in - extract_file types_config ctx file_info; + extract_file meta types_config ctx file_info; (* Extract the template clauses *) (if needs_clauses_module && !Config.extract_template_decreases_clauses then @@ -1298,7 +1300,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = []; } in - extract_file template_clauses_config ctx file_info); + extract_file meta template_clauses_config ctx file_info); (* Extract the opaque fun declarations, if needed *) let opaque_funs_module = @@ -1354,7 +1356,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = [ types_module ]; } in - extract_file opaque_config ctx file_info; + extract_file meta opaque_config ctx file_info; (* Return the additional dependencies *) [ opaque_imported_module ]) else [] @@ -1395,7 +1397,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : [ types_module ] @ opaque_funs_module @ clauses_module; } in - extract_file fun_config ctx file_info) + extract_file meta fun_config ctx file_info) else let gen_config = { @@ -1428,7 +1430,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = []; } in - extract_file gen_config ctx file_info); + extract_file meta gen_config ctx file_info); (* Generate the build file *) match !Config.backend with diff --git a/compiler/dune b/compiler/dune index 3a40e086..6bdfd153 100644 --- a/compiler/dune +++ b/compiler/dune @@ -19,6 +19,7 @@ ConstStrings Contexts Cps + Errors Expressions ExpressionsUtils Extract -- cgit v1.2.3 From 8f89bd8df9f382284eabb5a2020a2fa634f92fac Mon Sep 17 00:00:00 2001 From: Escherichia Date: Tue, 12 Mar 2024 17:19:14 +0100 Subject: WIP: does not compile yet because we need to propagate the meta variable. --- compiler/Contexts.ml | 73 ++++++++-------- compiler/Interpreter.ml | 20 ++--- compiler/InterpreterBorrows.ml | 10 +-- compiler/InterpreterExpansion.ml | 147 +++++++++++++++++---------------- compiler/InterpreterExpressions.ml | 94 ++++++++++----------- compiler/InterpreterLoopsFixedPoint.ml | 4 +- compiler/InterpreterPaths.ml | 12 +-- compiler/InterpreterStatements.ml | 46 +++++------ compiler/Main.ml | 2 +- compiler/SynthesizeSymbolic.ml | 35 ++++---- compiler/Translate.ml | 6 +- 11 files changed, 226 insertions(+), 223 deletions(-) (limited to 'compiler') diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 2563bd9d..6cdae078 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -5,6 +5,7 @@ open LlbcAst open LlbcAstUtils open ValuesUtils open Identifiers +open Errors module L = Logging (** The [Id] module for dummy variables. @@ -285,7 +286,7 @@ let lookup_const_generic_var (ctx : eval_ctx) (vid : ConstGenericVarId.id) : ConstGenericVarId.nth ctx.const_generic_vars vid (** Lookup a variable in the current frame *) -let env_lookup_var (env : env) (vid : VarId.id) : var_binder * typed_value = +let env_lookup_var (meta : Meta.meta) (env : env) (vid : VarId.id) : var_binder * typed_value = (* We take care to stop at the end of current frame: different variables in different frames can have the same id! *) @@ -296,12 +297,12 @@ let env_lookup_var (env : env) (vid : VarId.id) : var_binder * typed_value = | EBinding (BVar var, v) :: env' -> if var.index = vid then (var, v) else lookup env' | (EBinding (BDummy _, _) | EAbs _) :: env' -> lookup env' - | EFrame :: _ -> raise (Failure "End of frame") + | EFrame :: _ -> craise meta "End of frame" in lookup env -let ctx_lookup_var_binder (ctx : eval_ctx) (vid : VarId.id) : var_binder = - fst (env_lookup_var ctx.env vid) +let ctx_lookup_var_binder (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : var_binder = + fst (env_lookup_var meta ctx.env vid) let ctx_lookup_type_decl (ctx : eval_ctx) (tid : TypeDeclId.id) : type_decl = TypeDeclId.Map.find tid ctx.type_ctx.type_decls @@ -320,12 +321,12 @@ let ctx_lookup_trait_impl (ctx : eval_ctx) (id : TraitImplId.id) : trait_impl = TraitImplId.Map.find id ctx.trait_impls_ctx.trait_impls (** Retrieve a variable's value in the current frame *) -let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = - snd (env_lookup_var env vid) +let env_lookup_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) : typed_value = + snd (env_lookup_var meta env vid) (** Retrieve a variable's value in an evaluation context *) -let ctx_lookup_var_value (ctx : eval_ctx) (vid : VarId.id) : typed_value = - env_lookup_var_value ctx.env vid +let ctx_lookup_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : typed_value = + env_lookup_var_value meta ctx.env vid (** Retrieve a const generic value in an evaluation context *) let ctx_lookup_const_generic_value (ctx : eval_ctx) (vid : ConstGenericVarId.id) @@ -337,18 +338,18 @@ let ctx_lookup_const_generic_value (ctx : eval_ctx) (vid : ConstGenericVarId.id) This is a helper function: it can break invariants and doesn't perform any check. *) -let env_update_var_value (env : env) (vid : VarId.id) (nv : typed_value) : env = +let env_update_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) (nv : typed_value) : env = (* We take care to stop at the end of current frame: different variables in different frames can have the same id! *) let rec update env = match env with - | [] -> raise (Failure "Unexpected") + | [] -> craise meta "Unexpected" | EBinding ((BVar b as var), v) :: env' -> if b.index = vid then EBinding (var, nv) :: env' else EBinding (var, v) :: update env' | ((EBinding (BDummy _, _) | EAbs _) as ee) :: env' -> ee :: update env' - | EFrame :: _ -> raise (Failure "End of frame") + | EFrame :: _ -> craise meta "End of frame" in update env @@ -360,17 +361,17 @@ let var_to_binder (var : var) : var_binder = This is a helper function: it can break invariants and doesn't perform any check. *) -let ctx_update_var_value (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : +let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : eval_ctx = - { ctx with env = env_update_var_value ctx.env vid nv } + { ctx with env = env_update_var_value meta ctx.env vid nv } (** Push a variable in the context's environment. Checks that the pushed variable and its value have the same type (this is important). *) -let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - assert (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty); +let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = + cassert (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty) meta "Pushed variables and their values do not have the same type TODO: Error message"; let bv = var_to_binder var in { ctx with env = EBinding (BVar bv, v) :: ctx.env } @@ -379,7 +380,7 @@ let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = Checks that the pushed variables and their values have the same type (this is important). *) -let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx +let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx = log#ldebug (lazy @@ -390,11 +391,11 @@ let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx (* We can unfortunately not use Print because it depends on Contexts... *) show_var var ^ " -> " ^ show_typed_value value) vars))); - assert ( + cassert ( List.for_all (fun (var, (value : typed_value)) -> TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) - vars); + vars) meta "Pushed variables and their values do not have the same type TODO: Error message"; let vars = List.map (fun (var, value) -> EBinding (BVar (var_to_binder var), value)) @@ -416,11 +417,11 @@ let ctx_push_fresh_dummy_vars (ctx : eval_ctx) (vl : typed_value list) : List.fold_left (fun ctx v -> ctx_push_fresh_dummy_var ctx v) ctx vl (** Remove a dummy variable from a context's environment. *) -let ctx_remove_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : +let ctx_remove_dummy_var meta (ctx : eval_ctx) (vid : DummyVarId.id) : eval_ctx * typed_value = let rec remove_var (env : env) : env * typed_value = match env with - | [] -> raise (Failure "Could not lookup a dummy variable") + | [] -> craise meta "Could not lookup a dummy variable" | EBinding (BDummy vid', v) :: env when vid' = vid -> (env, v) | ee :: env -> let env, v = remove_var env in @@ -430,10 +431,10 @@ let ctx_remove_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : ({ ctx with env }, v) (** Lookup a dummy variable in a context's environment. *) -let ctx_lookup_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : typed_value = +let ctx_lookup_dummy_var (meta : Meta.meta) (ctx : eval_ctx) (vid : DummyVarId.id) : typed_value = let rec lookup_var (env : env) : typed_value = match env with - | [] -> raise (Failure "Could not lookup a dummy variable") + | [] -> craise meta "Could not lookup a dummy variable" | EBinding (BDummy vid', v) :: _env when vid' = vid -> v | _ :: env -> lookup_var env in @@ -449,13 +450,13 @@ let erase_regions (ty : ty) : ty = v#visit_ty () ty (** Push an uninitialized variable (which thus maps to {!constructor:Values.value.VBottom}) *) -let ctx_push_uninitialized_var (ctx : eval_ctx) (var : var) : eval_ctx = - ctx_push_var ctx var (mk_bottom (erase_regions var.var_ty)) +let ctx_push_uninitialized_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) : eval_ctx = + ctx_push_var meta ctx var (mk_bottom (erase_regions var.var_ty)) (** Push a list of uninitialized variables (which thus map to {!constructor:Values.value.VBottom}) *) -let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = +let ctx_push_uninitialized_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : var list) : eval_ctx = let vars = List.map (fun v -> (v, mk_bottom (erase_regions v.var_ty))) vars in - ctx_push_vars ctx vars + ctx_push_vars meta ctx vars let env_find_abs (env : env) (pred : abs -> bool) : abs option = let rec lookup env = @@ -474,10 +475,10 @@ let env_lookup_abs_opt (env : env) (abs_id : AbstractionId.id) : abs option = this abstraction (for instance, remove the abs id from all the parent sets of all the other abstractions). *) -let env_remove_abs (env : env) (abs_id : AbstractionId.id) : env * abs option = +let env_remove_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) : env * abs option = let rec remove (env : env) : env * abs option = match env with - | [] -> raise (Failure "Unreachable") + | [] -> craise meta "Unreachable" | EFrame :: _ -> (env, None) | EBinding (bv, v) :: env -> let env, abs_opt = remove env in @@ -499,11 +500,11 @@ let env_remove_abs (env : env) (abs_id : AbstractionId.id) : env * abs option = we also substitute the abstraction id wherever it is used (i.e., in the parent sets of the other abstractions). *) -let env_subst_abs (env : env) (abs_id : AbstractionId.id) (nabs : abs) : +let env_subst_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) (nabs : abs) : env * abs option = let rec update (env : env) : env * abs option = match env with - | [] -> raise (Failure "Unreachable") + | [] -> craise meta "Unreachable" | EFrame :: _ -> (* We're done *) (env, None) | EBinding (bv, v) :: env -> let env, opt_abs = update env in @@ -535,22 +536,22 @@ let ctx_find_abs (ctx : eval_ctx) (p : abs -> bool) : abs option = env_find_abs ctx.env p (** See the comments for {!env_remove_abs} *) -let ctx_remove_abs (ctx : eval_ctx) (abs_id : AbstractionId.id) : +let ctx_remove_abs (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) : eval_ctx * abs option = - let env, abs = env_remove_abs ctx.env abs_id in + let env, abs = env_remove_abs meta ctx.env abs_id in ({ ctx with env }, abs) (** See the comments for {!env_subst_abs} *) -let ctx_subst_abs (ctx : eval_ctx) (abs_id : AbstractionId.id) (nabs : abs) : +let ctx_subst_abs (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) (nabs : abs) : eval_ctx * abs option = - let env, abs_opt = env_subst_abs ctx.env abs_id nabs in + let env, abs_opt = env_subst_abs meta ctx.env abs_id nabs in ({ ctx with env }, abs_opt) -let ctx_set_abs_can_end (ctx : eval_ctx) (abs_id : AbstractionId.id) +let ctx_set_abs_can_end (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) (can_end : bool) : eval_ctx = let abs = ctx_lookup_abs ctx abs_id in let abs = { abs with can_end } in - fst (ctx_subst_abs ctx abs_id abs) + fst (ctx_subst_abs meta ctx abs_id abs) let ctx_type_decl_is_rec (ctx : eval_ctx) (id : TypeDeclId.id) : bool = let decl_group = TypeDeclId.Map.find id ctx.type_ctx.type_decls_groups in diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index ccae4588..961a64a4 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -173,7 +173,7 @@ let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) - the list of symbolic values introduced for the input values - the instantiated function signature *) -let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : +let initialize_symbolic_context_for_fun (meta : Meta.meta) (ctx : decls_ctx) (fdef : fun_decl) : eval_ctx * symbolic_value list * inst_fun_sig = (* The abstractions are not initialized the same way as for function * calls: they contain *loan* projectors, because they "provide" us @@ -232,12 +232,12 @@ let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : Collections.List.split_at (List.tl body.locals) body.arg_count in (* Push the return variable (initialized with ⊥) *) - let ctx = ctx_push_uninitialized_var ctx ret_var in + let ctx = ctx_push_uninitialized_var meta ctx ret_var in (* Push the input variables (initialized with symbolic values) *) let input_values = List.map mk_typed_value_from_symbolic_value input_svs in - let ctx = ctx_push_vars ctx (List.combine input_vars input_values) in + let ctx = ctx_push_vars meta ctx (List.combine input_vars input_values) in (* Push the remaining local variables (initialized with ⊥) *) - let ctx = ctx_push_uninitialized_vars ctx local_vars in + let ctx = ctx_push_uninitialized_vars meta ctx local_vars in (* Return *) (ctx, input_svs, inst_sg) @@ -468,7 +468,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) for the synthesis) - the symbolic AST generated by the symbolic execution *) -let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) +let evaluate_function_symbolic (meta : Meta.meta) (synthesize : bool) (ctx : decls_ctx) (fdef : fun_decl) : symbolic_value list * SA.expression option = (* Debug *) let name_to_string () = @@ -479,7 +479,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); (* Create the evaluation context *) - let ctx, input_svs, inst_sg = initialize_symbolic_context_for_fun ctx fdef in + let ctx, input_svs, inst_sg = initialize_symbolic_context_for_fun meta ctx fdef in let regions_hierarchy = FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies @@ -612,7 +612,7 @@ module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty environment. *) - let test_unit_function (crate : crate) (decls_ctx : decls_ctx) + let test_unit_function (meta : Meta.meta) (crate : crate) (decls_ctx : decls_ctx) (fid : FunDeclId.id) : unit = (* Retrieve the function declaration *) let fdef = FunDeclId.Map.find fid crate.fun_decls in @@ -634,7 +634,7 @@ module Test = struct let ctx = initialize_eval_ctx decls_ctx [] [] [] in (* Insert the (uninitialized) local variables *) - let ctx = ctx_push_uninitialized_vars ctx body.locals in + let ctx = ctx_push_uninitialized_vars meta ctx body.locals in (* Create the continuation to check the function's result *) let config = mk_config ConcreteMode in @@ -665,7 +665,7 @@ module Test = struct && def.signature.inputs = [] (** Test all the unit functions in a list of function definitions *) - let test_unit_functions (crate : crate) : unit = + let test_unit_functions (meta : Meta.meta) (crate : crate) : unit = let unit_funs = FunDeclId.Map.filter (fun _ -> fun_decl_is_transparent_unit) @@ -673,7 +673,7 @@ module Test = struct in let decls_ctx = compute_contexts crate in let test_unit_fun _ (def : fun_decl) : unit = - test_unit_function crate decls_ctx def.def_id + test_unit_function meta crate decls_ctx def.def_id in FunDeclId.Map.iter test_unit_fun unit_funs end diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index ae251fbf..e37a67b7 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -1030,7 +1030,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ (* Remove all the references to the id of the current abstraction, and remove * the abstraction itself. * **Rk.**: this is where we synthesize the updated symbolic AST *) - let cc = comp cc (end_abstraction_remove_from_context config abs_id) in + let cc = comp cc (end_abstraction_remove_from_context meta config abs_id) in (* Debugging *) let cc = @@ -1273,10 +1273,10 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow end_abstraction_borrows meta config chain abs_id cf ctx (** Remove an abstraction from the context, as well as all its references *) -and end_abstraction_remove_from_context (_config : config) +and end_abstraction_remove_from_context (meta : Meta.meta) (_config : config) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> - let ctx, abs = ctx_remove_abs ctx abs_id in + let ctx, abs = ctx_remove_abs meta ctx abs_id in let abs = Option.get abs in (* Apply the continuation *) let expr = cf ctx in @@ -2502,8 +2502,8 @@ let merge_into_abstraction (meta : Meta.meta) (abs_kind : abs_kind) (can_end : b (* Update the environment: replace the abstraction 1 with the result of the merge, remove the abstraction 0 *) - let ctx = fst (ctx_subst_abs ctx abs_id1 nabs) in - let ctx = fst (ctx_remove_abs ctx abs_id0) in + let ctx = fst (ctx_subst_abs meta ctx abs_id1 nabs) in + let ctx = fst (ctx_remove_abs meta ctx abs_id0) in (* Merge all the regions from the abstraction into one (the first - i.e., the one with the smallest id). Note that we need to do this in the whole diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index e489ddc3..0a5a289e 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -13,6 +13,7 @@ open ValuesUtils open InterpreterUtils open InterpreterProjectors open Print.EvalCtx +open Errors module S = SynthesizeSymbolic (** The local logger *) @@ -47,7 +48,7 @@ type proj_kind = LoanProj | BorrowProj Note that 2. and 3. may have a little bit of duplicated code, but hopefully it would make things clearer. *) -let apply_symbolic_expansion_to_target_avalues (config : config) +let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : config) (allow_reborrows : bool) (proj_kind : proj_kind) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = @@ -65,7 +66,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (** When visiting an abstraction, we remember the regions it owns to be able to properly reduce projectors when expanding symbolic values *) method! visit_abs current_abs abs = - assert (Option.is_none current_abs); + cassert (Option.is_none current_abs) meta "T"; let current_abs = Some abs in super#visit_abs current_abs abs @@ -77,7 +78,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) method! visit_aproj current_abs aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - assert (not (same_symbolic_id sv original_sv)) + cassert (not (same_symbolic_id sv original_sv)) meta "T" | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj current_abs aproj @@ -97,7 +98,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (* Check if this is the symbolic value we are looking for *) if same_symbolic_id sv original_sv then ( (* There mustn't be any given back values *) - assert (given_back = []); + cassert (given_back = []) meta "T"; (* Apply the projector *) let projected_value = apply_proj_loans_on_symbolic_expansion proj_regions @@ -145,11 +146,11 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (** Auxiliary function. Apply a symbolic expansion to avalues in a context. *) -let apply_symbolic_expansion_to_avalues (config : config) +let apply_symbolic_expansion_to_avalues (meta : Meta.meta) (config : config) (allow_reborrows : bool) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = let apply_expansion proj_kind ctx = - apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind + apply_symbolic_expansion_to_target_avalues meta config allow_reborrows proj_kind original_sv expansion ctx in (* First target the loan projectors, then the borrow projectors *) @@ -162,12 +163,12 @@ let apply_symbolic_expansion_to_avalues (config : config) Simply replace the symbolic values (*not avalues*) in the context with a given value. Will break invariants if not used properly. *) -let replace_symbolic_values (at_most_once : bool) (original_sv : symbolic_value) +let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) (original_sv : symbolic_value) (nv : value) (ctx : eval_ctx) : eval_ctx = (* Count *) let replaced = ref false in let replace () = - if at_most_once then assert (not !replaced); + if at_most_once then cassert (not !replaced) meta "T"; replaced := true; nv in @@ -186,16 +187,16 @@ let replace_symbolic_values (at_most_once : bool) (original_sv : symbolic_value) (* Return *) ctx -let apply_symbolic_expansion_non_borrow (config : config) +let apply_symbolic_expansion_non_borrow (meta : Meta.meta) (config : config) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = (* Apply the expansion to non-abstraction values *) let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in let at_most_once = false in - let ctx = replace_symbolic_values at_most_once original_sv nv.value ctx in + let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in (* Apply the expansion to abstraction values *) let allow_reborrows = false in - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + apply_symbolic_expansion_to_avalues meta config allow_reborrows original_sv expansion ctx (** Compute the expansion of a non-assumed (i.e.: not [Box], etc.) @@ -208,13 +209,13 @@ let apply_symbolic_expansion_non_borrow (config : config) [expand_enumerations] controls the expansion of enumerations: if false, it doesn't allow the expansion of enumerations *containing several variants*. *) -let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) +let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (expand_enumerations : bool) (def_id : TypeDeclId.id) (generics : generic_args) (ctx : eval_ctx) : symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) let def = ctx_lookup_type_decl ctx def_id in - assert (List.length generics.regions = List.length def.generics.regions); + cassert (List.length generics.regions = List.length def.generics.regions) meta "T"; (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = AssociatedTypes.type_decl_get_inst_norm_variants_fields_rtypes ctx def @@ -222,7 +223,7 @@ let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) in (* Check if there is strictly more than one variant *) if List.length variants_fields_types > 1 && not expand_enumerations then - raise (Failure "Not allowed to expand enumerations with several variants"); + craise meta "Not allowed to expand enumerations with several variants"; (* Initialize the expanded value for a given variant *) let initialize ((variant_id, field_types) : VariantId.id option * rty list) : symbolic_expansion = @@ -260,21 +261,21 @@ let compute_expanded_symbolic_box_value (boxed_ty : rty) : symbolic_expansion = [expand_enumerations] controls the expansion of enumerations: if [false], it doesn't allow the expansion of enumerations *containing several variants*. *) -let compute_expanded_symbolic_adt_value (expand_enumerations : bool) +let compute_expanded_symbolic_adt_value (meta : Meta.meta) (expand_enumerations : bool) (adt_id : type_id) (generics : generic_args) (ctx : eval_ctx) : symbolic_expansion list = match (adt_id, generics.regions, generics.types) with | TAdtId def_id, _, _ -> - compute_expanded_symbolic_non_assumed_adt_value expand_enumerations def_id + compute_expanded_symbolic_non_assumed_adt_value meta expand_enumerations def_id generics ctx | TTuple, [], _ -> [ compute_expanded_symbolic_tuple_value generics.types ] | TAssumed TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value boxed_ty ] | _ -> - raise - (Failure "compute_expanded_symbolic_adt_value: unexpected combination") + craise + meta "compute_expanded_symbolic_adt_value: unexpected combination" -let expand_symbolic_value_shared_borrow (config : config) +let expand_symbolic_value_shared_borrow (meta : Meta.meta) (config : config) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) (ref_ty : rty) : cm_fun = fun cf ctx -> @@ -307,7 +308,7 @@ let expand_symbolic_value_shared_borrow (config : config) Some [ AsbBorrow bid; shared_asb ] else (* Not in the set: ignore *) Some [ shared_asb ] - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" else None in (* The fresh symbolic value for the shared value *) @@ -324,7 +325,7 @@ let expand_symbolic_value_shared_borrow (config : config) else super#visit_VSymbolic env sv method! visit_EAbs proj_regions abs = - assert (Option.is_none proj_regions); + cassert (Option.is_none proj_regions) meta "T"; let proj_regions = Some abs.regions in super#visit_EAbs proj_regions abs @@ -349,7 +350,7 @@ let expand_symbolic_value_shared_borrow (config : config) method! visit_aproj proj_regions aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - assert (not (same_symbolic_id sv original_sv)) + cassert (not (same_symbolic_id sv original_sv)) meta "T" | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj proj_regions aproj @@ -375,27 +376,27 @@ let expand_symbolic_value_shared_borrow (config : config) let ctx = obj#visit_eval_ctx None ctx in (* Finally, replace the projectors on loans *) let bids = !borrows in - assert (not (BorrowId.Set.is_empty bids)); + cassert (not (BorrowId.Set.is_empty bids)) meta "T"; let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see + apply_symbolic_expansion_to_avalues meta config allow_reborrows original_sv see ctx in (* Call the continuation *) let expr = cf ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see + S.synthesize_symbolic_expansion_no_branching meta original_sv original_sv_place see expr (** TODO: simplify and merge with the other expansion function *) -let expand_symbolic_value_borrow (config : config) +let expand_symbolic_value_borrow (meta : Meta.meta) (config : config) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) (region : region) (ref_ty : rty) (rkind : ref_kind) : cm_fun = fun cf ctx -> - assert (region <> RErased); + cassert (region <> RErased) meta "T"; (* Check that we are allowed to expand the reference *) - assert (not (region_in_set region ctx.ended_regions)); + cassert (not (region_in_set region ctx.ended_regions)) meta "T"; (* Match on the reference kind *) match rkind with | RMut -> @@ -408,20 +409,20 @@ let expand_symbolic_value_borrow (config : config) * check that we perform exactly one substitution) *) let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in let at_most_once = true in - let ctx = replace_symbolic_values at_most_once original_sv nv.value ctx in + let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in (* Expand the symbolic avalues *) let allow_reborrows = true in let ctx = - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + apply_symbolic_expansion_to_avalues meta config allow_reborrows original_sv see ctx in (* Apply the continuation *) let expr = cf ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place + S.synthesize_symbolic_expansion_no_branching meta original_sv original_sv_place see expr | RShared -> - expand_symbolic_value_shared_borrow config original_sv original_sv_place + expand_symbolic_value_shared_borrow meta config original_sv original_sv_place ref_ty cf ctx (** A small helper. @@ -440,12 +441,12 @@ let expand_symbolic_value_borrow (config : config) We need this continuation separately (i.e., we can't compose it with the continuations in [see_cf_l]) because we perform a join *before* calling it. *) -let apply_branching_symbolic_expansions_non_borrow (config : config) +let apply_branching_symbolic_expansions_non_borrow (meta : Meta.meta) (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = fun ctx -> - assert (see_cf_l <> []); + cassert (see_cf_l <> []) meta "T"; (* Apply the symbolic expansion in the context and call the continuation *) let resl = List.map @@ -456,7 +457,7 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) let ctx = match see_opt with | None -> ctx - | Some see -> apply_symbolic_expansion_non_borrow config sv see ctx + | Some see -> apply_symbolic_expansion_non_borrow meta config sv see ctx in (* Debug *) log#ldebug @@ -475,15 +476,15 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) match resl with | Some _ :: _ -> Some (List.map Option.get resl) | None :: _ -> - List.iter (fun res -> assert (res = None)) resl; + List.iter (fun res -> cassert (res = None) meta "T") resl; None - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in (* Synthesize and return *) let seel = List.map fst see_cf_l in - S.synthesize_symbolic_expansion sv sv_place seel subterms + S.synthesize_symbolic_expansion meta sv sv_place seel subterms -let expand_symbolic_bool (config : config) (sv : symbolic_value) +let expand_symbolic_bool (meta : Meta.meta) (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) (cf_true : st_cm_fun) (cf_false : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> @@ -491,16 +492,16 @@ let expand_symbolic_bool (config : config) (sv : symbolic_value) let original_sv = sv in let original_sv_place = sv_place in let rty = original_sv.sv_ty in - assert (rty = TLiteral TBool); + cassert (rty = TLiteral TBool) meta "T"; (* Expand the symbolic value to true or false and continue execution *) let see_true = SeLiteral (VBool true) in let see_false = SeLiteral (VBool false) in let seel = [ (Some see_true, cf_true); (Some see_false, cf_false) ] in (* Apply the symbolic expansion (this also outputs the updated symbolic AST) *) - apply_branching_symbolic_expansions_non_borrow config original_sv + apply_branching_symbolic_expansions_non_borrow meta config original_sv original_sv_place seel cf_after_join ctx -let expand_symbolic_value_no_branching (config : config) (sv : symbolic_value) +let expand_symbolic_value_no_branching (meta : Meta.meta) (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) : cm_fun = fun cf ctx -> (* Debug *) @@ -522,29 +523,29 @@ let expand_symbolic_value_no_branching (config : config) (sv : symbolic_value) (* Compute the expanded value *) let allow_branching = false in let seel = - compute_expanded_symbolic_adt_value allow_branching adt_id generics + compute_expanded_symbolic_adt_value meta allow_branching adt_id generics ctx in (* There should be exacly one branch *) let see = Collections.List.to_cons_nil seel in (* Apply in the context *) let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx + apply_symbolic_expansion_non_borrow meta config original_sv see ctx in (* Call the continuation *) let expr = cf ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv + S.synthesize_symbolic_expansion_no_branching meta original_sv original_sv_place see expr (* Borrows *) | TRef (region, ref_ty, rkind) -> - expand_symbolic_value_borrow config original_sv original_sv_place region + expand_symbolic_value_borrow meta config original_sv original_sv_place region ref_ty rkind cf ctx | _ -> - raise - (Failure + craise + meta ("expand_symbolic_value_no_branching: unexpected type: " - ^ show_rty rty)) + ^ show_rty rty) in (* Debug *) let cc = @@ -556,12 +557,12 @@ let expand_symbolic_value_no_branching (config : config) (sv : symbolic_value) ^ "\n\n- original context:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* Sanity check: the symbolic value has disappeared *) - assert (not (symbolic_value_id_in_ctx original_sv.sv_id ctx))) + cassert (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta "T") in (* Continue *) cc cf ctx -let expand_symbolic_adt (config : config) (sv : symbolic_value) +let expand_symbolic_adt (meta : Meta.meta) (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) (cf_branches : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> @@ -579,21 +580,21 @@ let expand_symbolic_adt (config : config) (sv : symbolic_value) let allow_branching = true in (* Compute the expanded value *) let seel = - compute_expanded_symbolic_adt_value allow_branching adt_id generics ctx + compute_expanded_symbolic_adt_value meta allow_branching adt_id generics ctx in (* Apply *) let seel = List.map (fun see -> (Some see, cf_branches)) seel in - apply_branching_symbolic_expansions_non_borrow config original_sv + apply_branching_symbolic_expansions_non_borrow meta config original_sv original_sv_place seel cf_after_join ctx | _ -> - raise (Failure ("expand_symbolic_adt: unexpected type: " ^ show_rty rty)) + craise meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) -let expand_symbolic_int (config : config) (sv : symbolic_value) +let expand_symbolic_int (meta : Meta.meta) (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) (int_type : integer_type) (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) - assert (sv.sv_ty = TLiteral (TInteger int_type)); + cassert (sv.sv_ty = TLiteral (TInteger int_type)) meta "T"; (* For all the branches of the switch, we expand the symbolic value * to the value given by the branch and execute the branch statement. * For the otherwise branch, we leave the symbolic value as it is @@ -608,7 +609,7 @@ let expand_symbolic_int (config : config) (sv : symbolic_value) in let seel = List.append seel [ (None, otherwise) ] in (* Then expand and evaluate - this generates the proper symbolic AST *) - apply_branching_symbolic_expansions_non_borrow config sv sv_place seel + apply_branching_symbolic_expansions_non_borrow meta config sv sv_place seel cf_after_join (** Expand all the symbolic values which contain borrows. @@ -619,7 +620,7 @@ let expand_symbolic_int (config : config) (sv : symbolic_value) an enumeration with strictly more than one variant, a slice, etc.) or if we need to expand a recursive type (because this leads to looping). *) -let greedy_expand_symbolics_with_borrows (config : config) : cm_fun = +let greedy_expand_symbolics_with_borrows (meta : Meta.meta) (config : config) : cm_fun = fun cf ctx -> (* The visitor object, to look for symbolic values in the concrete environment *) let obj = @@ -660,33 +661,33 @@ let greedy_expand_symbolics_with_borrows (config : config) : cm_fun = (match def.kind with | Struct _ | Enum ([] | [ _ ]) -> () | Enum (_ :: _) -> - raise - (Failure + craise + meta ("Attempted to greedily expand a symbolic enumeration \ with > 1 variants (option \ [greedy_expand_symbolics_with_borrows] of [config]): " - ^ name_to_string ctx def.name)) + ^ name_to_string ctx def.name) | Opaque -> - raise (Failure "Attempted to greedily expand an opaque type")); + craise meta "Attempted to greedily expand an opaque type"); (* Also, we need to check if the definition is recursive *) if ctx_type_decl_is_rec ctx def_id then - raise - (Failure + craise + meta ("Attempted to greedily expand a recursive definition \ (option [greedy_expand_symbolics_with_borrows] of \ [config]): " - ^ name_to_string ctx def.name)) - else expand_symbolic_value_no_branching config sv None + ^ name_to_string ctx def.name) + else expand_symbolic_value_no_branching meta config sv None | TAdt ((TTuple | TAssumed TBox), _) | TRef (_, _, _) -> (* Ok *) - expand_symbolic_value_no_branching config sv None + expand_symbolic_value_no_branching meta config sv None | TAdt (TAssumed (TArray | TSlice | TStr), _) -> (* We can't expand those *) - raise - (Failure - "Attempted to greedily expand an ADT which can't be expanded ") + craise + meta + "Attempted to greedily expand an ADT which can't be expanded " | TVar _ | TLiteral _ | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> - raise (Failure "Unreachable") + craise meta "Unreachable" in (* Compose and continue *) comp cc expand cf ctx @@ -694,9 +695,9 @@ let greedy_expand_symbolics_with_borrows (config : config) : cm_fun = (* Apply *) expand cf ctx -let greedy_expand_symbolic_values (config : config) : cm_fun = +let greedy_expand_symbolic_values (meta : Meta.meta) (config : config) : cm_fun = fun cf ctx -> if Config.greedy_expand_symbolics_with_borrows then ( log#ldebug (lazy "greedy_expand_symbolic_values"); - greedy_expand_symbolics_with_borrows config cf ctx) + greedy_expand_symbolics_with_borrows meta config cf ctx) else cf ctx diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index afbf4605..51be904f 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -23,7 +23,7 @@ let log = Logging.expressions_log Note that the place should have been prepared so that there are no remaining loans. *) -let expand_primitively_copyable_at_place (config : config) +let expand_primitively_copyable_at_place (meta : Meta.meta) (config : config) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Small helper *) @@ -36,7 +36,7 @@ let expand_primitively_copyable_at_place (config : config) | None -> cf ctx | Some sv -> let cc = - expand_symbolic_value_no_branching config sv (Some (mk_mplace p ctx)) + expand_symbolic_value_no_branching config sv (Some (mk_mplace meta p ctx)) in comp cc expand cf ctx in @@ -59,7 +59,7 @@ let read_place (access : access_kind) (p : place) (cf : typed_value -> m_fun) : (* Call the continuation *) cf v ctx -let access_rplace_reorganize_and_read (config : config) +let access_rplace_reorganize_and_read (meta : Meta.meta) (config : config) (expand_prim_copy : bool) (access : access_kind) (p : place) (cf : typed_value -> m_fun) : m_fun = fun ctx -> @@ -71,7 +71,7 @@ let access_rplace_reorganize_and_read (config : config) * borrows) *) let cc = if expand_prim_copy then - comp cc (expand_primitively_copyable_at_place config access p) + comp cc (expand_primitively_copyable_at_place meta config access p) else cc in (* Read the place - note that this checks that the value doesn't contain bottoms *) @@ -79,10 +79,10 @@ let access_rplace_reorganize_and_read (config : config) (* Compose *) comp cc read_place cf ctx -let access_rplace_reorganize (config : config) (expand_prim_copy : bool) +let access_rplace_reorganize (meta : Meta.meta) (config : config) (expand_prim_copy : bool) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> - access_rplace_reorganize_and_read config expand_prim_copy access p + access_rplace_reorganize_and_read meta config expand_prim_copy access p (fun _v -> cf) ctx @@ -224,7 +224,7 @@ let rec copy_value (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) what we do in the formalization (because we don't enforce the same constraints as MIR in the formalization). *) -let prepare_eval_operand_reorganize (config : config) (op : operand) : cm_fun = +let prepare_eval_operand_reorganize (meta : Meta.meta) (config : config) (op : operand) : cm_fun = fun cf ctx -> let prepare : cm_fun = fun cf ctx -> @@ -237,12 +237,12 @@ let prepare_eval_operand_reorganize (config : config) (op : operand) : cm_fun = let access = Read in (* Expand the symbolic values, if necessary *) let expand_prim_copy = true in - access_rplace_reorganize config expand_prim_copy access p cf ctx + access_rplace_reorganize meta config expand_prim_copy access p cf ctx | Move p -> (* Access the value *) let access = Move in let expand_prim_copy = false in - access_rplace_reorganize config expand_prim_copy access p cf ctx + access_rplace_reorganize meta config expand_prim_copy access p cf ctx in (* Apply *) prepare cf ctx @@ -358,7 +358,7 @@ let eval_operand_no_reorganize (config : config) (op : operand) (* Compose and apply *) comp cc move cf ctx -let eval_operand (config : config) (op : operand) (cf : typed_value -> m_fun) : +let eval_operand (meta : Meta.meta) (config : config) (op : operand) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) @@ -368,7 +368,7 @@ let eval_operand (config : config) (op : operand) (cf : typed_value -> m_fun) : ^ eval_ctx_to_string ctx ^ "\n")); (* We reorganize the context, then evaluate the operand *) comp - (prepare_eval_operand_reorganize config op) + (prepare_eval_operand_reorganize meta config op) (eval_operand_no_reorganize config op) cf ctx @@ -376,16 +376,16 @@ let eval_operand (config : config) (op : operand) (cf : typed_value -> m_fun) : See [prepare_eval_operand_reorganize]. *) -let prepare_eval_operands_reorganize (config : config) (ops : operand list) : +let prepare_eval_operands_reorganize (meta : Meta.meta) (config : config) (ops : operand list) : cm_fun = - fold_left_apply_continuation (prepare_eval_operand_reorganize config) ops + fold_left_apply_continuation (prepare_eval_operand_reorganize meta config) ops (** Evaluate several operands. *) -let eval_operands (config : config) (ops : operand list) +let eval_operands (meta : Meta.meta) (config : config) (ops : operand list) (cf : typed_value list -> m_fun) : m_fun = fun ctx -> (* Prepare the operands *) - let prepare = prepare_eval_operands_reorganize config ops in + let prepare = prepare_eval_operands_reorganize meta config ops in (* Evaluate the operands *) let eval = fold_left_list_apply_continuation (eval_operand_no_reorganize config) ops @@ -393,9 +393,9 @@ let eval_operands (config : config) (ops : operand list) (* Compose and apply *) comp prepare eval cf ctx -let eval_two_operands (config : config) (op1 : operand) (op2 : operand) +let eval_two_operands (meta : Meta.meta) (config : config) (op1 : operand) (op2 : operand) (cf : typed_value * typed_value -> m_fun) : m_fun = - let eval_op = eval_operands config [ op1; op2 ] in + let eval_op = eval_operands meta config [ op1; op2 ] in let use_res cf res = match res with | [ v1; v2 ] -> cf (v1, v2) @@ -403,10 +403,10 @@ let eval_two_operands (config : config) (op1 : operand) (op2 : operand) in comp eval_op use_res cf -let eval_unary_op_concrete (config : config) (unop : unop) (op : operand) +let eval_unary_op_concrete (meta : Meta.meta) (config : config) (unop : unop) (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operand *) - let eval_op = eval_operand config op in + let eval_op = eval_operand meta config op in (* Apply the unop *) let apply cf (v : typed_value) : m_fun = match (unop, v.value) with @@ -451,11 +451,11 @@ let eval_unary_op_concrete (config : config) (unop : unop) (op : operand) in comp eval_op apply cf -let eval_unary_op_symbolic (config : config) (unop : unop) (op : operand) +let eval_unary_op_symbolic (meta : Meta.meta) (config : config) (unop : unop) (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operand *) - let eval_op = eval_operand config op in + let eval_op = eval_operand meta config op in (* Generate a fresh symbolic value to store the result *) let apply cf (v : typed_value) : m_fun = fun ctx -> @@ -472,17 +472,17 @@ let eval_unary_op_symbolic (config : config) (unop : unop) (op : operand) let expr = cf (Ok (mk_typed_value_from_symbolic_value res_sv)) ctx in (* Synthesize the symbolic AST *) synthesize_unary_op ctx unop v - (mk_opt_place_from_op op ctx) + (mk_opt_place_from_op meta op ctx) res_sv None expr in (* Compose and apply *) comp eval_op apply cf ctx -let eval_unary_op (config : config) (unop : unop) (op : operand) +let eval_unary_op (meta : Meta.meta) (config : config) (unop : unop) (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with - | ConcreteMode -> eval_unary_op_concrete config unop op cf - | SymbolicMode -> eval_unary_op_symbolic config unop op cf + | ConcreteMode -> eval_unary_op_concrete meta config unop op cf + | SymbolicMode -> eval_unary_op_symbolic meta config unop op cf (** Small helper for [eval_binary_op_concrete]: computes the result of applying the binop *after* the operands have been successfully evaluated @@ -557,10 +557,10 @@ let eval_binary_op_concrete_compute (binop : binop) (v1 : typed_value) | Ne | Eq -> raise (Failure "Unreachable")) | _ -> raise (Failure "Invalid inputs for binop") -let eval_binary_op_concrete (config : config) (binop : binop) (op1 : operand) +let eval_binary_op_concrete (meta : Meta.meta) (config : config) (binop : binop) (op1 : operand) (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operands *) - let eval_ops = eval_two_operands config op1 op2 in + let eval_ops = eval_two_operands meta config op1 op2 in (* Compute the result of the binop *) let compute cf (res : typed_value * typed_value) = let v1, v2 = res in @@ -569,11 +569,11 @@ let eval_binary_op_concrete (config : config) (binop : binop) (op1 : operand) (* Compose and apply *) comp eval_ops compute cf -let eval_binary_op_symbolic (config : config) (binop : binop) (op1 : operand) +let eval_binary_op_symbolic (meta : Meta.meta) (config : config) (binop : binop) (op1 : operand) (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operands *) - let eval_ops = eval_two_operands config op1 op2 in + let eval_ops = eval_two_operands meta config op1 op2 in (* Compute the result of applying the binop *) let compute cf ((v1, v2) : typed_value * typed_value) : m_fun = fun ctx -> @@ -609,20 +609,20 @@ let eval_binary_op_symbolic (config : config) (binop : binop) (op1 : operand) let v = mk_typed_value_from_symbolic_value res_sv in let expr = cf (Ok v) ctx in (* Synthesize the symbolic AST *) - let p1 = mk_opt_place_from_op op1 ctx in - let p2 = mk_opt_place_from_op op2 ctx in + let p1 = mk_opt_place_from_op meta op1 ctx in + let p2 = mk_opt_place_from_op meta op2 ctx in synthesize_binary_op ctx binop v1 p1 v2 p2 res_sv None expr in (* Compose and apply *) comp eval_ops compute cf ctx -let eval_binary_op (config : config) (binop : binop) (op1 : operand) +let eval_binary_op (meta : Meta.meta) (config : config) (binop : binop) (op1 : operand) (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with - | ConcreteMode -> eval_binary_op_concrete config binop op1 op2 cf - | SymbolicMode -> eval_binary_op_symbolic config binop op1 op2 cf + | ConcreteMode -> eval_binary_op_concrete meta config binop op1 op2 cf + | SymbolicMode -> eval_binary_op_symbolic meta config binop op1 op2 cf -let eval_rvalue_ref (config : config) (p : place) (bkind : borrow_kind) +let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : borrow_kind) (cf : typed_value -> m_fun) : m_fun = fun ctx -> match bkind with @@ -643,7 +643,7 @@ let eval_rvalue_ref (config : config) (p : place) (bkind : borrow_kind) let expand_prim_copy = false in let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p + access_rplace_reorganize_and_read meta config expand_prim_copy access p in (* Evaluate the borrowing operation *) let eval (cf : typed_value -> m_fun) (v : typed_value) : m_fun = @@ -693,7 +693,7 @@ let eval_rvalue_ref (config : config) (p : place) (bkind : borrow_kind) let access = Write in let expand_prim_copy = false in let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p + access_rplace_reorganize_and_read meta config expand_prim_copy access p in (* Evaluate the borrowing operation *) let eval (cf : typed_value -> m_fun) (v : typed_value) : m_fun = @@ -714,10 +714,10 @@ let eval_rvalue_ref (config : config) (p : place) (bkind : borrow_kind) (* Compose and apply *) comp prepare eval cf ctx -let eval_rvalue_aggregate (config : config) (aggregate_kind : aggregate_kind) +let eval_rvalue_aggregate (meta : Meta.meta) (config : config) (aggregate_kind : aggregate_kind) (ops : operand list) (cf : typed_value -> m_fun) : m_fun = (* Evaluate the operands *) - let eval_ops = eval_operands config ops in + let eval_ops = eval_operands meta config ops in (* Compute the value *) let compute (cf : typed_value -> m_fun) (values : typed_value list) : m_fun = fun ctx -> @@ -781,7 +781,7 @@ let eval_rvalue_aggregate (config : config) (aggregate_kind : aggregate_kind) (* Compose and apply *) comp eval_ops compute cf -let eval_rvalue_not_global (config : config) (rvalue : rvalue) +let eval_rvalue_not_global (meta : Meta.meta) (config : config) (rvalue : rvalue) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> log#ldebug (lazy "eval_rvalue"); @@ -793,12 +793,12 @@ let eval_rvalue_not_global (config : config) (rvalue : rvalue) let comp_wrap f = comp f wrap_in_result cf in (* Delegate to the proper auxiliary function *) match rvalue with - | Use op -> comp_wrap (eval_operand config op) ctx - | RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx - | UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx - | BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx + | Use op -> comp_wrap (eval_operand meta config op) ctx + | RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref meta config p bkind) ctx + | UnaryOp (unop, op) -> eval_unary_op meta config unop op cf ctx + | BinaryOp (binop, op1, op2) -> eval_binary_op meta config binop op1 op2 cf ctx | Aggregate (aggregate_kind, ops) -> - comp_wrap (eval_rvalue_aggregate config aggregate_kind ops) ctx + comp_wrap (eval_rvalue_aggregate meta config aggregate_kind ops) ctx | Discriminant _ -> raise (Failure @@ -806,11 +806,11 @@ let eval_rvalue_not_global (config : config) (rvalue : rvalue) the AST") | Global _ -> raise (Failure "Unreachable") -let eval_fake_read (config : config) (p : place) : cm_fun = +let eval_fake_read (meta : Meta.meta) (config : config) (p : place) : cm_fun = fun cf ctx -> let expand_prim_copy = false in let cf_prepare cf = - access_rplace_reorganize_and_read config expand_prim_copy Read p cf + access_rplace_reorganize_and_read meta config expand_prim_copy Read p cf in let cf_continue cf v : m_fun = fun ctx -> diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index b07ba943..35582456 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -693,7 +693,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id AbstractionId.of_int (RegionGroupId.to_int rg_id) in (* By default, the [SynthInput] abs can't end *) - let ctx = ctx_set_abs_can_end ctx abs_id true in + let ctx = ctx_set_abs_can_end meta ctx abs_id true in cassert ( let abs = ctx_lookup_abs ctx abs_id in abs.kind = SynthInput rg_id) meta "TODO : error message "; @@ -764,7 +764,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id in let abs = ctx_lookup_abs !fp !id0 in let abs = { abs with kind = abs_kind } in - let fp', _ = ctx_subst_abs !fp !id0 abs in + let fp', _ = ctx_subst_abs meta !fp !id0 abs in fp := fp'; (* Merge all the abstractions into this one *) List.iter diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index e411db9b..cc1e3208 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -259,13 +259,13 @@ let access_place (meta : Meta.meta) (access : projection_access) (update : typed_value -> typed_value) (p : place) (ctx : eval_ctx) : (eval_ctx * typed_value) path_access_result = (* Lookup the variable's value *) - let value = ctx_lookup_var_value ctx p.var_id in + let value = ctx_lookup_var_value meta ctx p.var_id in (* Apply the projection *) match access_projection meta access ctx update p.projection value with | Error err -> Error err | Ok (ctx, res) -> (* Update the value *) - let ctx = ctx_update_var_value ctx p.var_id res.updated in + let ctx = ctx_update_var_value meta ctx p.var_id res.updated in (* Return *) Ok (ctx, res.read) @@ -465,7 +465,7 @@ let rec update_ctx_along_read_place (meta : Meta.meta) (config : config) (access in let prefix = { p with projection = proj } in expand_symbolic_value_no_branching config sp - (Some (Synth.mk_mplace prefix ctx)) + (Some (Synth.mk_mplace meta prefix ctx)) | FailBottom (_, _, _) -> (* We can't expand {!Bottom} values while reading them *) craise meta "Found [Bottom] while reading a place" @@ -490,7 +490,7 @@ let rec update_ctx_along_write_place (meta : Meta.meta) (config : config) (acces | FailSymbolic (_pe, sp) -> (* Expand the symbolic value *) expand_symbolic_value_no_branching config sp - (Some (Synth.mk_mplace p ctx)) + (Some (Synth.mk_mplace meta p ctx)) | FailBottom (remaining_pes, pe, ty) -> (* Expand the {!Bottom} value *) fun cf ctx -> @@ -575,7 +575,7 @@ let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) let rec drop : cm_fun = fun cf ctx -> (* Read the value *) - let v = ctx_lookup_dummy_var ctx dummy_id in + let v = ctx_lookup_dummy_var meta ctx dummy_id in (* Check if there are loans or borrows to end *) let with_borrows = false in match get_first_outer_loan_or_borrow_in_value with_borrows v with @@ -599,7 +599,7 @@ let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) let cc = comp cc (fun cf ctx -> (* Pop *) - let ctx, v = ctx_remove_dummy_var ctx dummy_id in + let ctx, v = ctx_remove_dummy_var meta ctx dummy_id in (* Reinsert *) let ctx = write_place meta access p v ctx in (* Sanity check *) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index bd6fab1a..8ccdcc93 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -58,33 +58,33 @@ let push_dummy_var (vid : DummyVarId.id) (v : typed_value) : cm_fun = cf ctx (** Remove a dummy variable from the environment *) -let remove_dummy_var (vid : DummyVarId.id) (cf : typed_value -> m_fun) : m_fun = +let remove_dummy_var (meta : Meta.meta) (vid : DummyVarId.id) (cf : typed_value -> m_fun) : m_fun = fun ctx -> - let ctx, v = ctx_remove_dummy_var ctx vid in + let ctx, v = ctx_remove_dummy_var meta ctx vid in cf v ctx (** Push an uninitialized variable to the environment *) -let push_uninitialized_var (var : var) : cm_fun = +let push_uninitialized_var (meta : Meta.meta) (var : var) : cm_fun = fun cf ctx -> - let ctx = ctx_push_uninitialized_var ctx var in + let ctx = ctx_push_uninitialized_var meta ctx var in cf ctx (** Push a list of uninitialized variables to the environment *) -let push_uninitialized_vars (vars : var list) : cm_fun = +let push_uninitialized_vars (meta : Meta.meta) (vars : var list) : cm_fun = fun cf ctx -> - let ctx = ctx_push_uninitialized_vars ctx vars in + let ctx = ctx_push_uninitialized_vars meta ctx vars in cf ctx (** Push a variable to the environment *) -let push_var (var : var) (v : typed_value) : cm_fun = +let push_var (meta : Meta.meta) (var : var) (v : typed_value) : cm_fun = fun cf ctx -> - let ctx = ctx_push_var ctx var v in + let ctx = ctx_push_var meta ctx var v in cf ctx (** Push a list of variables to the environment *) -let push_vars (vars : (var * typed_value) list) : cm_fun = +let push_vars (meta : Meta.meta) (vars : (var * typed_value) list) : cm_fun = fun cf ctx -> - let ctx = ctx_push_vars ctx vars in + let ctx = ctx_push_vars meta ctx vars in cf ctx (** Assign a value to a given place. @@ -108,7 +108,7 @@ let assign_to_place (meta : Meta.meta) (config : config) (rv : typed_value) (p : (* Prepare the destination *) let cc = comp cc (prepare_lplace config p) in (* Retrieve the rvalue from the dummy variable *) - let cc = comp cc (fun cf _lv -> remove_dummy_var rvalue_vid cf) in + let cc = comp cc (fun cf _lv -> remove_dummy_var meta rvalue_vid cf) in (* Update the destination *) let move_dest cf (rv : typed_value) : m_fun = fun ctx -> @@ -538,7 +538,7 @@ let eval_assumed_function_call_concrete (meta : Meta.meta) (config : config) (fi let ret_vid = VarId.zero in let ret_ty = get_assumed_function_return_type meta ctx fid generics in let ret_var = mk_var ret_vid (Some "@return") ret_ty in - let cc = comp cc (push_uninitialized_var ret_var) in + let cc = comp cc (push_uninitialized_var meta ret_var) in (* Create and push the input variables *) let input_vars = @@ -546,7 +546,7 @@ let eval_assumed_function_call_concrete (meta : Meta.meta) (config : config) (fi (fun id (v : typed_value) -> (mk_var id None v.ty, v)) args_vl in - let cc = comp cc (push_vars input_vars) in + let cc = comp cc (push_vars meta input_vars) in (* "Execute" the function body. As the functions are assumed, here we call * custom functions to perform the proper manipulations: we don't have @@ -981,10 +981,10 @@ let rec eval_statement (meta : Meta.meta) (config : config) (st : statement) : s let rp = rvalue_get_place rvalue in let rp = match rp with - | Some rp -> Some (S.mk_mplace rp ctx) + | Some rp -> Some (S.mk_mplace meta rp ctx) | None -> None in - S.synthesize_assignment ctx (S.mk_mplace p ctx) rv rp expr + S.synthesize_assignment ctx (S.mk_mplace meta p ctx) rv rp expr ) in @@ -1094,7 +1094,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f let cf_true : st_cm_fun = eval_statement meta config st1 in let cf_false : st_cm_fun = eval_statement meta config st2 in expand_symbolic_bool config sv - (S.mk_opt_place_from_op op ctx) + (S.mk_opt_place_from_op meta op ctx) cf_true cf_false cf ctx | _ -> craise meta "Inconsistent state" in @@ -1141,7 +1141,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f let otherwise = eval_statement meta config otherwise in (* Expand and continue *) expand_symbolic_int config sv - (S.mk_opt_place_from_op op ctx) + (S.mk_opt_place_from_op meta op ctx) int_ty stgts otherwise cf ctx | _ -> craise meta "Inconsistent state" in @@ -1175,7 +1175,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f | VSymbolic sv -> (* Expand the symbolic value - may lead to branching *) let cf_expand = - expand_symbolic_adt config sv (Some (S.mk_mplace p ctx)) + expand_symbolic_adt config sv (Some (S.mk_mplace meta p ctx)) in (* Re-evaluate the switch - the value is not symbolic anymore, which means we will go to the other branch *) @@ -1280,7 +1280,7 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) in let cc = - comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) + comp_transmit cc (push_var meta ret_var (mk_bottom ret_var.var_ty)) in (* 2. Push the input values *) @@ -1288,12 +1288,12 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) let inputs = List.combine input_locals args in (* Note that this function checks that the variables and their values * have the same type (this is important) *) - push_vars inputs cf + push_vars meta inputs cf in let cc = comp cc cf_push_inputs in (* 3. Push the remaining local variables (initialized as {!Bottom}) *) - let cc = comp cc (push_uninitialized_vars locals) in + let cc = comp cc (push_uninitialized_vars meta locals) in (* Execute the function body *) let cc = comp cc (eval_function_body meta config body_st) in @@ -1366,8 +1366,8 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi let ret_av regions = mk_aproj_loans_value_from_symbolic_value regions ret_spc in - let args_places = List.map (fun p -> S.mk_opt_place_from_op p ctx) args in - let dest_place = Some (S.mk_mplace dest ctx) in + let args_places = List.map (fun p -> S.mk_opt_place_from_op meta p ctx) args in + let dest_place = Some (S.mk_mplace meta dest ctx) in (* Evaluate the input operands *) let cc = eval_operands config args in diff --git a/compiler/Main.ml b/compiler/Main.ml index e4e4ce1f..bea7e4a8 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -271,7 +271,7 @@ let () = (* Some options for the execution *) (* Test the unit functions with the concrete interpreter *) - if !test_unit_functions then Test.test_unit_functions m; + if !test_unit_functions then Test.test_unit_functions meta m; (* Translate the functions *) Aeneas.Translate.translate_crate meta filename dest_dir m; diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index ad34c48e..787bfb4f 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -4,21 +4,22 @@ open Expressions open Values open LlbcAst open SymbolicAst +open Errors -let mk_mplace (p : place) (ctx : Contexts.eval_ctx) : mplace = - let bv = Contexts.ctx_lookup_var_binder ctx p.var_id in +let mk_mplace (meta : Meta.meta) (p : place) (ctx : Contexts.eval_ctx) : mplace = + let bv = Contexts.ctx_lookup_var_binder meta ctx p.var_id in { bv; projection = p.projection } -let mk_opt_mplace (p : place option) (ctx : Contexts.eval_ctx) : mplace option = - Option.map (fun p -> mk_mplace p ctx) p +let mk_opt_mplace (meta : Meta.meta) (p : place option) (ctx : Contexts.eval_ctx) : mplace option = + Option.map (fun p -> mk_mplace meta p ctx) p -let mk_opt_place_from_op (op : operand) (ctx : Contexts.eval_ctx) : +let mk_opt_place_from_op (meta : Meta.meta) (op : operand) (ctx : Contexts.eval_ctx) : mplace option = - match op with Copy p | Move p -> Some (mk_mplace p ctx) | Constant _ -> None + match op with Copy p | Move p -> Some (mk_mplace meta p ctx) | Constant _ -> None let mk_emeta (m : emeta) (e : expression) : expression = Meta (m, e) -let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) +let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (place : mplace option) (seel : symbolic_expansion option list) (el : expression list option) : expression option = match el with @@ -36,7 +37,7 @@ let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) (Some (SeLiteral (VBool false)), false_exp); ] -> ExpandBool (true_exp, false_exp) - | _ -> raise (Failure "Ill-formed boolean expansion")) + | _ -> craise meta "Ill-formed boolean expansion") | TLiteral (TInteger int_ty) -> (* Switch over an integer: split between the "regular" branches and the "otherwise" branch (which should be the last branch) *) @@ -46,9 +47,9 @@ let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) let get_scalar (see : symbolic_expansion option) : scalar_value = match see with | Some (SeLiteral (VScalar cv)) -> - assert (cv.int_ty = int_ty); + cassert (cv.int_ty = int_ty) meta "For all the regular branches, the symbolic value should have been expanded to a constant TODO: Error message"; cv - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in let branches = List.map (fun (see, exp) -> (get_scalar see, exp)) branches @@ -56,7 +57,7 @@ let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) (* For the otherwise branch, the symbolic value should have been left * unchanged *) let otherwise_see, otherwise = otherwise in - assert (otherwise_see = None); + cassert (otherwise_see = None) meta "For the otherwise branch, the symbolic value should have been left unchanged"; (* Return *) ExpandInt (int_ty, branches, otherwise) | TAdt (_, _) -> @@ -65,7 +66,7 @@ let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) VariantId.id option * symbolic_value list = match see with | Some (SeAdt (vid, fields)) -> (vid, fields) - | _ -> raise (Failure "Ill-formed branching ADT expansion") + | _ -> craise meta "Ill-formed branching ADT expansion" in let exp = List.map @@ -79,18 +80,18 @@ let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) (* Reference expansion: there should be one branch *) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) - | _ -> raise (Failure "Ill-formed borrow expansion")) + | _ -> craise meta "Ill-formed borrow expansion") | TVar _ | TLiteral TChar | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> - raise (Failure "Ill-formed symbolic expansion") + craise meta "Ill-formed symbolic expansion" in Some (Expansion (place, sv, expansion)) -let synthesize_symbolic_expansion_no_branching (sv : symbolic_value) +let synthesize_symbolic_expansion_no_branching (meta : Meta.meta) (sv : symbolic_value) (place : mplace option) (see : symbolic_expansion) (e : expression option) : expression option = let el = Option.map (fun e -> [ e ]) e in - synthesize_symbolic_expansion sv place [ Some see ] el + synthesize_symbolic_expansion meta sv place [ Some see ] el let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) (sg : fun_sig option) (regions_hierarchy : region_var_groups) @@ -188,7 +189,7 @@ let synthesize_loop (loop_id : LoopId.id) (input_svalues : symbolic_value list) loop_expr; meta; }) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" let save_snapshot (ctx : Contexts.eval_ctx) (e : expression option) : expression option = diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 04aadafe..43d2fbb0 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -20,7 +20,7 @@ type symbolic_fun_translation = symbolic_value list * SA.expression (** Execute the symbolic interpreter on a function to generate a list of symbolic ASTs, for the forward function and the backward functions. *) -let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : fun_decl) : +let translate_function_to_symbolics (meta : Meta.meta) (trans_ctx : trans_ctx) (fdef : fun_decl) : symbolic_fun_translation option = (* Debug *) log#ldebug @@ -32,7 +32,7 @@ let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : fun_decl) : | Some _ -> (* Evaluate *) let synthesize = true in - let inputs, symb = evaluate_function_symbolic synthesize trans_ctx fdef in + let inputs, symb = evaluate_function_symbolic meta synthesize trans_ctx fdef in Some (inputs, Option.get symb) (** Translate a function, by generating its forward and backward translations. @@ -50,7 +50,7 @@ let translate_function_to_pure (meta : Meta.meta) (trans_ctx : trans_ctx) (lazy ("translate_function_to_pure: " ^ name_to_string trans_ctx fdef.name)); (* Compute the symbolic ASTs, if the function is transparent *) - let symbolic_trans = translate_function_to_symbolics trans_ctx fdef in + let symbolic_trans = translate_function_to_symbolics meta trans_ctx fdef in (* Convert the symbolic ASTs to pure ASTs: *) -- cgit v1.2.3 From 5209cea7012cfa3b39a5a289e65e2ea5e166d730 Mon Sep 17 00:00:00 2001 From: Escherichia Date: Thu, 21 Mar 2024 12:34:40 +0100 Subject: WIP: translate.ml and extract.ml do not compile. Some assert left to do and we need to see how translate_crate can give meta to the functions it calls --- compiler/AssociatedTypes.ml | 33 +- compiler/Contexts.ml | 4 +- compiler/Errors.ml | 23 +- compiler/Extract.ml | 370 ++++++++++---------- compiler/ExtractBase.ml | 275 +++++++-------- compiler/ExtractName.ml | 5 +- compiler/ExtractTypes.ml | 217 ++++++------ compiler/FunsAnalysis.ml | 10 +- compiler/Interpreter.ml | 87 ++--- compiler/InterpreterBorrows.ml | 92 ++--- compiler/InterpreterBorrows.mli | 27 +- compiler/InterpreterBorrowsCore.ml | 24 +- compiler/InterpreterExpansion.ml | 68 ++-- compiler/InterpreterExpansion.mli | 10 +- compiler/InterpreterExpressions.ml | 185 +++++----- compiler/InterpreterExpressions.mli | 12 +- compiler/InterpreterLoops.ml | 55 +-- compiler/InterpreterLoopsCore.ml | 30 +- compiler/InterpreterLoopsFixedPoint.ml | 62 ++-- compiler/InterpreterLoopsFixedPoint.mli | 7 +- compiler/InterpreterLoopsJoinCtxs.ml | 66 ++-- compiler/InterpreterLoopsJoinCtxs.mli | 4 +- compiler/InterpreterLoopsMatchCtxs.ml | 310 ++++++++--------- compiler/InterpreterLoopsMatchCtxs.mli | 6 +- compiler/InterpreterPaths.ml | 64 ++-- compiler/InterpreterPaths.mli | 17 +- compiler/InterpreterProjectors.ml | 30 +- compiler/InterpreterProjectors.mli | 10 +- compiler/InterpreterStatements.ml | 182 +++++----- compiler/InterpreterStatements.mli | 4 +- compiler/InterpreterUtils.ml | 51 +-- compiler/Invariants.ml | 168 ++++----- compiler/Main.ml | 4 +- compiler/PrePasses.ml | 16 +- compiler/Print.ml | 135 ++++---- compiler/PrintPure.ml | 125 +++---- compiler/PureMicroPasses.ml | 53 +-- compiler/PureTypeCheck.ml | 151 ++++---- compiler/PureUtils.ml | 99 +++--- compiler/RegionsHierarchy.ml | 31 +- compiler/Substitute.ml | 29 +- compiler/SymbolicToPure.ml | 591 ++++++++++++++++---------------- compiler/Translate.ml | 50 +-- compiler/TypesAnalysis.ml | 3 +- compiler/ValuesUtils.ml | 37 +- 45 files changed, 1947 insertions(+), 1885 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 7b928566..cce5a082 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -11,6 +11,7 @@ open TypesUtils open Values open LlbcAst open Contexts +open Errors module Subst = Substitute (** The local logger *) @@ -33,7 +34,7 @@ end module TyMap = Collections.MakeMap (TyOrd) -let compute_norm_trait_types_from_preds +let compute_norm_trait_types_from_preds (meta : Meta.meta option) (trait_type_constraints : trait_type_constraint list) : ty TraitTypeRefMap.t = (* Compute a union-find structure by recursively exploring the predicates and clauses *) @@ -50,7 +51,7 @@ let compute_norm_trait_types_from_preds (* Sanity check: the type constraint can't make use of regions - Remark that it would be enough to only visit the field [ty] of the trait type constraint, but for safety we visit all the fields *) - assert (trait_type_constraint_no_regions c); + cassert_opt_meta (trait_type_constraint_no_regions c) meta "TODO: error message"; let { trait_ref; type_name; ty } : trait_type_constraint = c in let trait_ty = TTraitType (trait_ref, type_name) in let trait_ty_ref = get_ref trait_ty in @@ -79,10 +80,10 @@ let compute_norm_trait_types_from_preds in TraitTypeRefMap.of_list rbindings -let ctx_add_norm_trait_types_from_preds (ctx : eval_ctx) +let ctx_add_norm_trait_types_from_preds (meta : Meta.meta) (ctx : eval_ctx) (trait_type_constraints : trait_type_constraint list) : eval_ctx = let norm_trait_types = - compute_norm_trait_types_from_preds trait_type_constraints + compute_norm_trait_types_from_preds (Some meta) trait_type_constraints in { ctx with norm_trait_types } @@ -237,7 +238,8 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = match trait_ref.trait_id with | TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ } -> - assert (ref_generics = empty_generic_args); + let meta = (TraitImplId.Map.find impl_id ctx.trait_impls).meta in + cassert (ref_generics = empty_generic_args) meta "Higher order types are not supported yet TODO: error message"; log#ldebug (lazy ("norm_ctx_normalize_ty: trait type: trait ref: " @@ -277,7 +279,8 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* We can't project *) - assert (trait_instance_id_is_local_clause trait_ref.trait_id); + let meta = (TraitDeclId.Map.find trait_ref.trait_decl_ref.trait_decl_id ctx.trait_decls).meta in + cassert (trait_instance_id_is_local_clause trait_ref.trait_id) meta "TODO: error message"; TTraitType (trait_ref, type_name) in let tr : trait_type_ref = { trait_ref; type_name } in @@ -342,10 +345,11 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | ParentClause (inst_id, decl_id, clause_id) -> ( let inst_id, impl = norm_ctx_normalize_trait_instance_id ctx inst_id in (* Check if the inst_id refers to a specific implementation, if yes project *) + let meta = (TraitDeclId.Map.find decl_id ctx.trait_decls).meta in match impl with | None -> (* This is actually a local clause *) - assert (trait_instance_id_is_local_clause inst_id); + cassert (trait_instance_id_is_local_clause inst_id) meta "TODO: error message"; (ParentClause (inst_id, decl_id, clause_id), None) | Some impl -> (* We figure out the parent clause by doing the following: @@ -371,12 +375,13 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) let clause = norm_ctx_normalize_trait_ref ctx clause in (TraitRef clause, Some clause)) | ItemClause (inst_id, decl_id, item_name, clause_id) -> ( + let meta = (TraitDeclId.Map.find decl_id ctx.trait_decls).meta in let inst_id, impl = norm_ctx_normalize_trait_instance_id ctx inst_id in (* Check if the inst_id refers to a specific implementation, if yes project *) match impl with | None -> (* This is actually a local clause *) - assert (trait_instance_id_is_local_clause inst_id); + cassert (trait_instance_id_is_local_clause inst_id) meta "Trait instance id is not a local clause"; (ItemClause (inst_id, decl_id, item_name, clause_id), None) | Some impl -> (* We figure out the item clause by doing the following: @@ -416,8 +421,9 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) - assert (trait_instance_id_is_local_clause trait_ref.trait_id); - assert (trait_ref.generics = empty_generic_args); + let meta = (TraitDeclId.Map.find trait_ref.trait_decl_ref.trait_decl_id ctx.trait_decls).meta in + cassert (trait_instance_id_is_local_clause trait_ref.trait_id) meta "Trait instance id is not a local sub-clause"; + cassert (trait_ref.generics = empty_generic_args) meta "TODO: error message"; (trait_ref.trait_id, None) | FnPointer ty -> let ty = norm_ctx_normalize_ty ctx ty in @@ -466,7 +472,8 @@ and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : trait_ref) : (lazy ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); - assert (generics = empty_generic_args); + let meta = (TraitDeclId.Map.find trait_ref.trait_decl_ref.trait_decl_id ctx.trait_decls).meta in + cassert (generics = empty_generic_args) meta "TODO: error message"; trait_ref (* Not sure this one is really necessary *) @@ -528,10 +535,10 @@ let type_decl_get_inst_norm_field_rtypes (ctx : eval_ctx) (def : type_decl) List.map (ctx_normalize_ty ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) -let ctx_adt_value_get_inst_norm_field_rtypes (ctx : eval_ctx) (adt : adt_value) +let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (adt : adt_value) (id : type_id) (generics : generic_args) : ty list = let types = - Subst.ctx_adt_value_get_instantiated_field_types ctx adt id generics + Subst.ctx_adt_value_get_instantiated_field_types meta ctx adt id generics in List.map (ctx_normalize_ty ctx) types diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 6cdae078..558aaa4e 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -451,11 +451,11 @@ let erase_regions (ty : ty) : ty = (** Push an uninitialized variable (which thus maps to {!constructor:Values.value.VBottom}) *) let ctx_push_uninitialized_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) : eval_ctx = - ctx_push_var meta ctx var (mk_bottom (erase_regions var.var_ty)) + ctx_push_var meta ctx var (mk_bottom meta (erase_regions var.var_ty)) (** Push a list of uninitialized variables (which thus map to {!constructor:Values.value.VBottom}) *) let ctx_push_uninitialized_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : var list) : eval_ctx = - let vars = List.map (fun v -> (v, mk_bottom (erase_regions v.var_ty))) vars in + let vars = List.map (fun v -> (v, mk_bottom meta (erase_regions v.var_ty))) vars in ctx_push_vars meta ctx vars let env_find_abs (env : env) (pred : abs -> bool) : abs option = diff --git a/compiler/Errors.ml b/compiler/Errors.ml index 65c2cbb0..8fb65bc1 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -12,16 +12,31 @@ let format_error_message (meta : Meta.meta) msg = exception CFailure of string -let error_list : (Meta.meta * string) list ref = ref [] -let save_error (meta : Meta.meta ) (msg : string) = error_list := (meta, msg)::(!error_list) +let error_list : (Meta.meta option * string) list ref = ref [] +let save_error (meta : Meta.meta option) (msg : string) = error_list := (meta, msg)::(!error_list) let craise (meta : Meta.meta) (msg : string) = if !Config.fail_hard then raise (Failure (format_error_message meta msg)) else - let () = save_error meta msg in + let () = save_error (Some meta) msg in raise (CFailure msg) let cassert (b : bool) (meta : Meta.meta) (msg : string) = if b then - craise meta msg \ No newline at end of file + craise meta msg + +let craise_opt_meta (meta : Meta.meta option) (msg : string) = + match meta with + | Some m -> craise m msg + | None -> + let () = save_error (None) msg in + raise (CFailure msg) + +let cassert_opt_meta (b : bool) (meta : Meta.meta option) (msg : string) = + match meta with + | Some m -> cassert b m msg + | None -> + if b then + let () = save_error (None) msg in + raise (CFailure msg) \ No newline at end of file diff --git a/compiler/Extract.ml b/compiler/Extract.ml index aa097a4f..246fc82f 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -7,6 +7,7 @@ open Pure open PureUtils open TranslateCore open Config +open Errors include ExtractTypes (** Compute the names for all the pure functions generated from a rust function. @@ -59,7 +60,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (* Add the decreases proof for Lean only *) match !Config.backend with | Coq | FStar -> ctx - | HOL4 -> raise (Failure "Unexpected") + | HOL4 -> craise def.meta "Unexpected" | Lean -> ctx_add_decreases_proof def ctx else ctx in @@ -89,7 +90,7 @@ let extract_global_decl_register_names (ctx : extraction_ctx) TODO: we don't need something very generic anymore (some definitions used to be polymorphic). *) -let extract_adt_g_value +let extract_adt_g_value (meta : Meta.meta) (extract_value : extraction_ctx -> bool -> 'v -> extraction_ctx) (fmt : F.formatter) (ctx : extraction_ctx) (is_single_pat : bool) (inside : bool) (variant_id : VariantId.id option) (field_values : 'v list) @@ -127,8 +128,8 @@ let extract_adt_g_value | TAdt (TTuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) - assert (List.length generics.types = List.length field_values); - assert (generics.const_generics = [] && generics.trait_refs = []); + cassert (List.length generics.types = List.length field_values) meta "Only applied tuple constructors are currently supported"; + cassert (generics.const_generics = [] && generics.trait_refs = []) meta "Only applied tuple constructors are currently supported"; extract_as_tuple () | TAdt (adt_id, _) -> (* "Regular" ADT *) @@ -167,8 +168,8 @@ let extract_adt_g_value *) let cons = match variant_id with - | Some vid -> ctx_get_variant adt_id vid ctx - | None -> ctx_get_struct adt_id ctx + | Some vid -> ctx_get_variant meta adt_id vid ctx + | None -> ctx_get_struct meta adt_id ctx in let use_parentheses = inside && field_values <> [] in if use_parentheses then F.pp_print_string fmt "("; @@ -182,16 +183,17 @@ let extract_adt_g_value in if use_parentheses then F.pp_print_string fmt ")"; ctx - | _ -> raise (Failure "Inconsistent typed value") + | _ -> craise meta "Inconsistent typed value" (* Extract globals in the same way as variables *) -let extract_global (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) +let extract_global (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (id : A.GlobalDeclId.id) (generics : generic_args) : unit = + (* let trait_decl = GlobalDeclId.Map.find id ctx.trait_decl_id in there might be a way to extract the meta ? *) let use_brackets = inside && generics <> empty_generic_args in F.pp_open_hvbox fmt ctx.indent_incr; if use_brackets then F.pp_print_string fmt "("; (* Extract the global name *) - F.pp_print_string fmt (ctx_get_global id ctx); + F.pp_print_string fmt (ctx_get_global meta id ctx); (* Extract the generics *) extract_generic_args ctx fmt TypeDeclId.Set.empty generics; if use_brackets then F.pp_print_string fmt ")"; @@ -231,7 +233,7 @@ let fun_builtin_filter_types (id : FunDeclId.id) (types : 'a list) As a pattern can introduce new variables, we return an extraction context updated with new bindings. *) -let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) +let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (is_let : bool) (inside : bool) ?(with_type = false) (v : typed_pattern) : extraction_ctx = if with_type then F.pp_print_string fmt "("; @@ -239,11 +241,11 @@ let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) let ctx = match v.value with | PatConstant cv -> - extract_literal fmt inside cv; + extract_literal meta fmt inside cv; ctx | PatVar (v, _) -> - let vname = ctx_compute_var_basename ctx v.basename v.ty in - let ctx, vname = ctx_add_var vname v.id ctx in + let vname = ctx_compute_var_basename meta ctx v.basename v.ty in + let ctx, vname = ctx_add_var meta vname v.id ctx in F.pp_print_string fmt vname; ctx | PatDummy -> @@ -251,22 +253,22 @@ let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) ctx | PatAdt av -> let extract_value ctx inside v = - extract_typed_pattern ctx fmt is_let inside v + extract_typed_pattern meta ctx fmt is_let inside v in - extract_adt_g_value extract_value fmt ctx is_let inside av.variant_id + extract_adt_g_value meta extract_value fmt ctx is_let inside av.variant_id av.field_values v.ty in if with_type then ( F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty false v.ty; + extract_ty meta ctx fmt TypeDeclId.Set.empty false v.ty; F.pp_print_string fmt ")"); ctx (** Return true if we need to wrap a succession of let-bindings in a [do ...] block (because some of them are monadic) *) -let lets_require_wrap_in_do (lets : (bool * typed_pattern * texpression) list) : +let lets_require_wrap_in_do (meta : Meta.meta) (lets : (bool * typed_pattern * texpression) list) : bool = match !backend with | Lean -> @@ -275,7 +277,7 @@ let lets_require_wrap_in_do (lets : (bool * typed_pattern * texpression) list) : | HOL4 -> (* HOL4 is similar to HOL4, but we add a sanity check *) let wrap_in_do = List.exists (fun (m, _, _) -> m) lets in - if wrap_in_do then assert (List.for_all (fun (m, _, _) -> m) lets); + if wrap_in_do then cassert (List.for_all (fun (m, _, _) -> m) lets) meta "TODO: error message"; wrap_in_do | FStar | Coq -> false @@ -289,37 +291,37 @@ let lets_require_wrap_in_do (lets : (bool * typed_pattern * texpression) list) : - application argument: [f (exp)] - match/if scrutinee: [if exp then _ else _]/[match exp | _ -> _] *) -let rec extract_texpression (ctx : extraction_ctx) (fmt : F.formatter) +let rec extract_texpression (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (e : texpression) : unit = match e.e with | Var var_id -> - let var_name = ctx_get_var var_id ctx in + let var_name = ctx_get_var meta var_id ctx in F.pp_print_string fmt var_name | CVar var_id -> - let var_name = ctx_get_const_generic_var var_id ctx in + let var_name = ctx_get_const_generic_var meta var_id ctx in F.pp_print_string fmt var_name - | Const cv -> extract_literal fmt inside cv + | Const cv -> extract_literal meta fmt inside cv | App _ -> let app, args = destruct_apps e in - extract_App ctx fmt inside app args + extract_App meta ctx fmt inside app args | Lambda _ -> let xl, e = destruct_lambdas e in - extract_Lambda ctx fmt inside xl e + extract_Lambda (meta : Meta.meta) ctx fmt inside xl e | Qualif _ -> (* We use the app case *) - extract_App ctx fmt inside e [] - | Let (_, _, _, _) -> extract_lets ctx fmt inside e - | Switch (scrut, body) -> extract_Switch ctx fmt inside scrut body - | Meta (_, e) -> extract_texpression ctx fmt inside e - | StructUpdate supd -> extract_StructUpdate ctx fmt inside e.ty supd + extract_App meta ctx fmt inside e [] + | Let (_, _, _, _) -> extract_lets meta ctx fmt inside e + | Switch (scrut, body) -> extract_Switch meta ctx fmt inside scrut body + | Meta (_, e) -> extract_texpression meta ctx fmt inside e + | StructUpdate supd -> extract_StructUpdate meta ctx fmt inside e.ty supd | Loop _ -> (* The loop nodes should have been eliminated in {!PureMicroPasses} *) - raise (Failure "Unreachable") + craise meta "Unreachable" (* Extract an application *or* a top-level qualif (function extraction has * to handle top-level qualifiers, so it seemed more natural to merge the * two cases) *) -and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) +and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (app : texpression) (args : texpression list) : unit = (* We don't do the same thing if the app is a top-level identifier (function, * ADT constructor...) or a "regular" expression *) @@ -328,18 +330,18 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (* Top-level qualifier *) match qualif.id with | FunOrOp fun_id -> - extract_function_call ctx fmt inside fun_id qualif.generics args + extract_function_call meta ctx fmt inside fun_id qualif.generics args | Global global_id -> assert (args = []); - extract_global ctx fmt inside global_id qualif.generics + extract_global meta ctx fmt inside global_id qualif.generics | AdtCons adt_cons_id -> - extract_adt_cons ctx fmt inside adt_cons_id qualif.generics args + extract_adt_cons meta ctx fmt inside adt_cons_id qualif.generics args | Proj proj -> extract_field_projector ctx fmt inside app proj qualif.generics args | TraitConst (trait_ref, const_name) -> - extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref; + extract_trait_ref meta ctx fmt TypeDeclId.Set.empty true trait_ref; let name = - ctx_get_trait_const trait_ref.trait_decl_ref.trait_decl_id + ctx_get_trait_const meta trait_ref.trait_decl_ref.trait_decl_id const_name ctx in let add_brackets (s : string) = @@ -354,12 +356,12 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the app expression *) let app_inside = (inside && args = []) || args <> [] in - extract_texpression ctx fmt app_inside app; + extract_texpression meta ctx fmt app_inside app; (* Print the arguments *) List.iter (fun ve -> F.pp_print_space fmt (); - extract_texpression ctx fmt true ve) + extract_texpression meta ctx fmt true ve) args; (* Close the box for the application *) F.pp_close_box fmt (); @@ -367,7 +369,7 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) if inside then F.pp_print_string fmt ")" (** Subcase of the app case: function call *) -and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) +and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (fid : fun_or_op_id) (generics : generic_args) (args : texpression list) : unit = match (fid, args) with @@ -376,11 +378,11 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) * Note that the way we generate the translation, we shouldn't get the * case where we have no argument (all functions are fully instantiated, * and no AST transformation introduces partial calls). *) - extract_unop (extract_texpression ctx fmt) fmt inside unop arg + extract_unop meta (extract_texpression meta ctx fmt) fmt inside unop arg | Binop (binop, int_ty), [ arg0; arg1 ] -> (* Number of arguments: similar to unop *) - extract_binop - (extract_texpression ctx fmt) + extract_binop meta + (extract_texpression meta ctx fmt) fmt inside binop int_ty arg0 arg1 | Fun fun_id, _ -> if inside then F.pp_print_string fmt "("; @@ -447,8 +449,8 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) if not method_id.is_provided then ( (* Required method *) - assert (lp_id = None); - extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref; + cassert (lp_id = None) trait_decl.meta "TODO: Error message"; + extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref; let fun_name = ctx_get_trait_method trait_ref.trait_decl_ref.trait_decl_id method_name ctx @@ -461,7 +463,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) (* Provided method: we see it as a regular function call, and use the function name *) let fun_id = FromLlbc (FunId (FRegular method_id.id), lp_id) in - let fun_name = ctx_get_function fun_id ctx in + let fun_name = ctx_get_function trait_decl.meta fun_id ctx in F.pp_print_string fmt fun_name; (* Note that we do not need to print the generics for the trait @@ -470,13 +472,13 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) Print the trait ref (to instantate the self clause) *) F.pp_print_space fmt (); - extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref + extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref | _ -> - let fun_name = ctx_get_function fun_id ctx in + let fun_name = ctx_get_function meta fun_id ctx in F.pp_print_string fmt fun_name); (* Sanity check: HOL4 doesn't support const generics *) - assert (generics.const_generics = [] || !backend <> HOL4); + cassert (generics.const_generics = [] || !backend <> HOL4) meta "TODO: error message"; (* Print the generics. We might need to filter some of the type arguments, if the type @@ -491,12 +493,12 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) in (match types with | Ok types -> - extract_generic_args ctx fmt TypeDeclId.Set.empty + extract_generic_args meta ctx fmt TypeDeclId.Set.empty { generics with types } | Error (types, err) -> - extract_generic_args ctx fmt TypeDeclId.Set.empty + extract_generic_args meta ctx fmt TypeDeclId.Set.empty { generics with types }; - if !Config.fail_hard then raise (Failure err) + if !Config.fail_hard then craise meta err else F.pp_print_string fmt "(\"ERROR: ill-formed builtin: invalid number of filtering \ @@ -505,38 +507,38 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun ve -> F.pp_print_space fmt (); - extract_texpression ctx fmt true ve) + extract_texpression meta ctx fmt true ve) args; (* Close the box for the function call *) F.pp_close_box fmt (); (* Return *) if inside then F.pp_print_string fmt ")" | (Unop _ | Binop _), _ -> - raise - (Failure + craise + meta ("Unreachable:\n" ^ "Function: " ^ show_fun_or_op_id fid ^ ",\nNumber of arguments: " ^ string_of_int (List.length args) ^ ",\nArguments: " - ^ String.concat " " (List.map show_texpression args))) + ^ String.concat " " (List.map show_texpression args)) (** Subcase of the app case: ADT constructor *) -and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) +and extract_adt_cons (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (adt_cons : adt_cons_id) (generics : generic_args) (args : texpression list) : unit = let e_ty = TAdt (adt_cons.adt_id, generics) in let is_single_pat = false in let _ = - extract_adt_g_value + extract_adt_g_value meta (fun ctx inside e -> - extract_texpression ctx fmt inside e; + extract_texpression meta ctx fmt inside e; ctx) fmt ctx is_single_pat inside adt_cons.variant_id args e_ty in () (** Subcase of the app case: ADT field projector. *) -and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) +and extract_field_projector (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (original_app : texpression) (proj : projection) (_generics : generic_args) (args : texpression list) : unit = (* We isolate the first argument (if there is), in order to pretty print the @@ -562,7 +564,7 @@ and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) match num_fields with Some len -> len = 1 | None -> false in if is_tuple_struct && has_one_field then - extract_texpression ctx fmt inside arg + extract_texpression meta ctx fmt inside arg else (* Exactly one argument: pretty-print *) let field_name = @@ -613,12 +615,12 @@ and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) if field_id + 1 = Option.get num_fields then twos_prefix else twos_prefix ^ ".1" else "#" ^ string_of_int field_id - else ctx_get_field proj.adt_id proj.field_id ctx + else ctx_get_field meta proj.adt_id proj.field_id ctx in (* Open a box *) F.pp_open_hovbox fmt ctx.indent_incr; (* Extract the expression *) - extract_texpression ctx fmt true arg; + extract_texpression meta ctx fmt true arg; (* We allow to break where the "." appears (except Lean, it's a syntax error) *) if !backend <> Lean then F.pp_print_break fmt 0 0; F.pp_print_string fmt "."; @@ -631,26 +633,26 @@ and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) | arg :: args -> (* Call extract_App again, but in such a way that the first argument is * isolated *) - extract_App ctx fmt inside (mk_app original_app arg) args + extract_App meta ctx fmt inside (mk_app meta original_app arg) args | [] -> (* No argument: shouldn't happen *) - raise (Failure "Unreachable") + craise meta "Unreachable" -and extract_Lambda (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) +and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (xl : typed_pattern list) (e : texpression) : unit = (* Open a box for the abs expression *) F.pp_open_hovbox fmt ctx.indent_incr; (* Open parentheses *) if inside then F.pp_print_string fmt "("; (* Print the lambda - note that there should always be at least one variable *) - assert (xl <> []); + cassert (xl <> []) meta "TODO: error message"; F.pp_print_string fmt "fun"; let with_type = !backend = Coq in let ctx = List.fold_left (fun ctx x -> F.pp_print_space fmt (); - extract_typed_pattern ctx fmt true true ~with_type x) + extract_typed_pattern meta ctx fmt true true ~with_type x) ctx xl in F.pp_print_space fmt (); @@ -658,13 +660,13 @@ and extract_Lambda (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) else F.pp_print_string fmt "->"; F.pp_print_space fmt (); (* Print the body *) - extract_texpression ctx fmt false e; + extract_texpression meta ctx fmt false e; (* Close parentheses *) if inside then F.pp_print_string fmt ")"; (* Close the box for the abs expression *) F.pp_close_box fmt () -and extract_lets (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) +and extract_lets (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (e : texpression) : unit = (* Destruct the lets. @@ -690,7 +692,7 @@ and extract_lets (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) *) let lets, next_e = match !backend with - | HOL4 -> destruct_lets_no_interleave e + | HOL4 -> destruct_lets_no_interleave meta e | FStar | Coq | Lean -> destruct_lets e in (* Extract the let-bindings *) @@ -711,16 +713,16 @@ and extract_lets (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) * TODO: cleanup * *) if monadic && (!backend = Coq || !backend = HOL4) then ( - let ctx = extract_typed_pattern ctx fmt true true lv in + let ctx = extract_typed_pattern meta ctx fmt true true lv in F.pp_print_space fmt (); let arrow = match !backend with | Coq | HOL4 -> "<-" - | FStar | Lean -> raise (Failure "impossible") + | FStar | Lean -> craise meta "impossible" in F.pp_print_string fmt arrow; F.pp_print_space fmt (); - extract_texpression ctx fmt false re; + extract_texpression meta ctx fmt false re; F.pp_print_string fmt ";"; ctx) else ( @@ -737,7 +739,7 @@ and extract_lets (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) else ( F.pp_print_string fmt "let"; F.pp_print_space fmt ()); - let ctx = extract_typed_pattern ctx fmt true true lv in + let ctx = extract_typed_pattern meta ctx fmt true true lv in F.pp_print_space fmt (); let eq = match !backend with @@ -748,7 +750,7 @@ and extract_lets (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) in F.pp_print_string fmt eq; F.pp_print_space fmt (); - extract_texpression ctx fmt false re; + extract_texpression meta ctx fmt false re; (* End the let-binding *) (match !backend with | Lean -> @@ -776,7 +778,7 @@ and extract_lets (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) if inside && !backend <> Lean then F.pp_print_string fmt "("; (* If Lean and HOL4, we rely on monadic blocks, so we insert a do and open a new box immediately *) - let wrap_in_do_od = lets_require_wrap_in_do lets in + let wrap_in_do_od = lets_require_wrap_in_do meta lets in if wrap_in_do_od then ( F.pp_print_string fmt "do"; F.pp_print_space fmt ()); @@ -788,7 +790,7 @@ and extract_lets (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (* Open a box for the next expression *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the next expression *) - extract_texpression ctx fmt false next_e; + extract_texpression meta ctx fmt false next_e; (* Close the box for the next expression *) F.pp_close_box fmt (); @@ -802,7 +804,7 @@ and extract_lets (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (* Close the box for the whole expression *) F.pp_close_box fmt () -and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) +and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) (scrut : texpression) (body : switch_body) : unit = (* Remark: we don't use the [inside] parameter because we extract matches in a conservative manner: we always make sure they are parenthesized/delimited @@ -821,8 +823,8 @@ and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) F.pp_print_string fmt "if"; if !backend = Lean && ctx.use_dep_ite then F.pp_print_string fmt " h:"; F.pp_print_space fmt (); - let scrut_inside = PureUtils.texpression_requires_parentheses scrut in - extract_texpression ctx fmt scrut_inside scrut; + let scrut_inside = PureUtils.texpression_requires_parentheses meta scrut in + extract_texpression meta ctx fmt scrut_inside scrut; (* Close the box for the [if e] *) F.pp_close_box fmt (); @@ -835,7 +837,7 @@ and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) F.pp_open_hovbox fmt 0; let then_or_else = if is_then then "then" else "else" in F.pp_print_string fmt then_or_else; - let parenth = PureUtils.texpression_requires_parentheses e_branch in + let parenth = PureUtils.texpression_requires_parentheses meta e_branch in (* Open the parenthesized expression *) let print_space_after_parenth = if parenth then ( @@ -856,7 +858,7 @@ and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) (* Open a box for the branch *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the branch expression *) - extract_texpression ctx fmt false e_branch; + extract_texpression meta ctx fmt false e_branch; (* Close the box for the branch *) F.pp_close_box fmt (); (* Close the parenthesized expression *) @@ -887,8 +889,8 @@ and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) in F.pp_print_string fmt match_begin; F.pp_print_space fmt (); - let scrut_inside = PureUtils.texpression_requires_parentheses scrut in - extract_texpression ctx fmt scrut_inside scrut; + let scrut_inside = PureUtils.texpression_requires_parentheses meta scrut in + extract_texpression meta ctx fmt scrut_inside scrut; F.pp_print_space fmt (); let match_scrut_end = match !backend with FStar | Coq | Lean -> "with" | HOL4 -> "of" @@ -907,7 +909,7 @@ and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) (* Print the pattern *) F.pp_print_string fmt "|"; F.pp_print_space fmt (); - let ctx = extract_typed_pattern ctx fmt false false br.pat in + let ctx = extract_typed_pattern meta ctx fmt false false br.pat in F.pp_print_space fmt (); let arrow = match !backend with FStar -> "->" | Coq | Lean | HOL4 -> "=>" @@ -919,7 +921,7 @@ and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) (* Open a box for the branch *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the branch itself *) - extract_texpression ctx fmt false br.branch; + extract_texpression meta ctx fmt false br.branch; (* Close the box for the branch *) F.pp_close_box fmt (); (* Close the box for the pattern+branch *) @@ -938,11 +940,11 @@ and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) (* Close the box for the whole expression *) F.pp_close_box fmt () -and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) +and extract_StructUpdate (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (e_ty : ty) (supd : struct_update) : unit = (* We can't update a subset of the fields in Coq (i.e., we can do [{| x:= 3; y := 4 |}], but there is no syntax for [{| s with x := 3 |}]) *) - assert (!backend <> Coq || supd.init = None); + cassert (!backend <> Coq || supd.init = None) meta "TODO: error message"; (* In the case of HOL4, records with no fields are not supported and are thus extracted to unit. We need to check that by looking up the definition *) let extract_as_unit = @@ -1007,7 +1009,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) if need_paren then F.pp_print_string fmt "("; F.pp_open_hvbox fmt ctx.indent_incr; if supd.init <> None then ( - let var_name = ctx_get_var (Option.get supd.init) ctx in + let var_name = ctx_get_var meta (Option.get supd.init) ctx in F.pp_print_string fmt var_name; F.pp_print_space fmt (); F.pp_print_string fmt "with"; @@ -1026,12 +1028,12 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt ()) (fun (fid, fe) -> F.pp_open_hvbox fmt ctx.indent_incr; - let f = ctx_get_field supd.struct_id fid ctx in + let f = ctx_get_field meta supd.struct_id fid ctx in F.pp_print_string fmt f; F.pp_print_string fmt (" " ^ assign); F.pp_print_space fmt (); F.pp_open_hvbox fmt ctx.indent_incr; - extract_texpression ctx fmt true fe; + extract_texpression meta ctx fmt true fe; F.pp_close_box fmt (); F.pp_close_box fmt ()) supd.updates; @@ -1050,16 +1052,16 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for `Array.replicate T N [` *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the array constructor *) - let cs = ctx_get_struct (TAssumed TArray) ctx in + let cs = ctx_get_struct meta (TAssumed TArray) ctx in F.pp_print_string fmt cs; (* Print the parameters *) - let _, generics = ty_as_adt e_ty in + let _, generics = ty_as_adt meta e_ty in let ty = Collections.List.to_cons_nil generics.types in F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty true ty; + extract_ty meta ctx fmt TypeDeclId.Set.empty true ty; let cg = Collections.List.to_cons_nil generics.const_generics in F.pp_print_space fmt (); - extract_const_generic ctx fmt true cg; + extract_const_generic meta ctx fmt true cg; F.pp_print_space fmt (); F.pp_print_string fmt "["; (* Close the box for `Array.mk T N [` *) @@ -1074,7 +1076,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) (fun () -> F.pp_print_string fmt delimiter; F.pp_print_space fmt ()) - (fun (_, fe) -> extract_texpression ctx fmt false fe) + (fun (_, fe) -> extract_texpression meta ctx fmt false fe) supd.updates; (* Close the boxes *) F.pp_close_box fmt (); @@ -1082,7 +1084,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "]"; if need_paren then F.pp_print_string fmt ")"; F.pp_close_box fmt () - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" (** A small utility to print the parameters of a function signature. @@ -1116,7 +1118,7 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) match def.kind with | TraitItemProvided (decl_id, _) -> let trait_decl = T.TraitDeclId.Map.find decl_id ctx.trans_trait_decls in - let ctx, _ = ctx_add_trait_self_clause ctx in + let ctx, _ = ctx_add_trait_self_clause def.meta ctx in let ctx = { ctx with is_provided_method = true } in (ctx, Some trait_decl) | _ -> (ctx, None) @@ -1124,14 +1126,14 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) (* Add the type parameters - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params def.llbc_name def.signature.llbc_generics + ctx_add_generic_params def.meta def.llbc_name def.signature.llbc_generics def.signature.generics ctx in (* Print the generics *) (* Open a box for the generics *) F.pp_open_hovbox fmt 0; (let space = Some space in - extract_generic_params ctx fmt TypeDeclId.Set.empty ~space ~trait_decl + extract_generic_params def.meta ctx fmt TypeDeclId.Set.empty ~space ~trait_decl def.signature.generics type_params cg_params trait_clauses); (* Close the box for the generics *) F.pp_close_box fmt (); @@ -1146,11 +1148,11 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) (* Open a box for the input parameter *) F.pp_open_hovbox fmt 0; F.pp_print_string fmt "("; - let ctx = extract_typed_pattern ctx fmt true false lv in + let ctx = extract_typed_pattern def.meta ctx fmt true false lv in F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty false lv.ty; + extract_ty def.meta ctx fmt TypeDeclId.Set.empty false lv.ty; F.pp_print_string fmt ")"; (* Close the box for the input parameters *) F.pp_close_box fmt (); @@ -1169,7 +1171,7 @@ let extract_fun_input_parameters_types (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = let extract_param (ty : ty) : unit = let inside = false in - extract_ty ctx fmt TypeDeclId.Set.empty inside ty; + extract_ty def.meta ctx fmt TypeDeclId.Set.empty inside ty; F.pp_print_space fmt (); extract_arrow fmt (); F.pp_print_space fmt () @@ -1179,14 +1181,14 @@ let extract_fun_input_parameters_types (ctx : extraction_ctx) let extract_fun_inputs_output_parameters_types (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = extract_fun_input_parameters_types ctx fmt def; - extract_ty ctx fmt TypeDeclId.Set.empty false def.signature.output + extract_ty def.meta ctx fmt TypeDeclId.Set.empty false def.signature.output -let assert_backend_supports_decreases_clauses () = +let assert_backend_supports_decreases_clauses (meta : Meta.meta) = match !backend with | FStar | Lean -> () | _ -> - raise - (Failure "decreases clauses only supported for the Lean & F* backends") + craise + meta "decreases clauses only supported for the Lean & F* backends" (** Extract a decreases clause function template body. @@ -1206,10 +1208,10 @@ let assert_backend_supports_decreases_clauses () = *) let extract_template_fstar_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - assert (!backend = FStar); + cassert (!backend = FStar) def.meta "TODO: error message"; (* Retrieve the function name *) - let def_name = ctx_get_termination_measure def.def_id def.loop_id ctx in + let def_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) @@ -1271,12 +1273,12 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) *) let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - assert (!backend = Lean); + cassert (!backend = Lean) def.meta "TODO: error message"; (* * Extract a template for the termination measure *) (* Retrieve the function name *) - let def_name = ctx_get_termination_measure def.def_id def.loop_id ctx in + let def_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in let def_body = Option.get def.body in (* Add a break before *) F.pp_print_break fmt 0 0; @@ -1311,7 +1313,7 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) let vars = List.map (fun (v : var) -> v.id) def_body.inputs in if List.length vars = 1 then - F.pp_print_string fmt (ctx_get_var (List.hd vars) ctx_body) + F.pp_print_string fmt (ctx_get_var def.meta (List.hd vars) ctx_body) else ( F.pp_open_hovbox fmt 0; F.pp_print_string fmt "("; @@ -1319,7 +1321,7 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (fun () -> F.pp_print_string fmt ","; F.pp_print_space fmt ()) - (fun v -> F.pp_print_string fmt (ctx_get_var v ctx_body)) + (fun v -> F.pp_print_string fmt (ctx_get_var def.meta v ctx_body)) vars; F.pp_print_string fmt ")"; F.pp_close_box fmt ()); @@ -1333,7 +1335,7 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (* * Extract a template for the decreases proof *) - let def_name = ctx_get_decreases_proof def.def_id def.loop_id ctx in + let def_name = ctx_get_decreases_proof def.meta def.def_id def.loop_id ctx in (* syntax term ... term : tactic *) F.pp_print_break fmt 0 0; extract_comment_with_span ctx fmt @@ -1356,7 +1358,7 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (fun v -> F.pp_print_space fmt (); F.pp_print_string fmt "$"; - F.pp_print_string fmt (ctx_get_var v ctx_body)) + F.pp_print_string fmt (ctx_get_var def.meta v ctx_body)) vars; F.pp_print_string fmt ") =>"; F.pp_close_box fmt (); @@ -1394,9 +1396,9 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - assert (not def.is_global_decl_body); + cassert (not def.is_global_decl_body) def.meta "TODO: error message"; (* Retrieve the function name *) - let def_name = ctx_get_local_function def.def_id def.loop_id ctx in + let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then F.pp_print_break fmt 0 0; @@ -1466,18 +1468,18 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) if is_opaque then extract_fun_input_parameters_types ctx fmt def; (* [Tot] *) if has_decreases_clause then ( - assert_backend_supports_decreases_clauses (); + assert_backend_supports_decreases_clauses def.meta; if !backend = FStar then ( F.pp_print_string fmt "Tot"; F.pp_print_space fmt ())); - extract_ty ctx fmt TypeDeclId.Set.empty has_decreases_clause + extract_ty def.meta ctx fmt TypeDeclId.Set.empty has_decreases_clause def.signature.output; (* Close the box for the return type *) F.pp_close_box fmt (); (* Print the decrease clause - rk.: a function with a decreases clause * is necessarily a transparent function *) if has_decreases_clause && !backend = FStar then ( - assert_backend_supports_decreases_clauses (); + assert_backend_supports_decreases_clauses def.meta; F.pp_print_space fmt (); (* Open a box for the decreases clause *) F.pp_open_hovbox fmt ctx.indent_incr; @@ -1487,7 +1489,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open a box for the decreases term *) F.pp_open_hovbox fmt ctx.indent_incr; (* The name of the decrease clause *) - let decr_name = ctx_get_termination_measure def.def_id def.loop_id ctx in + let decr_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in F.pp_print_string fmt decr_name; (* Print the generic parameters - TODO: we do this many times, we should have a helper to factor it out *) @@ -1517,7 +1519,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) List.fold_left (fun ctx (lv : typed_pattern) -> F.pp_print_space fmt (); - let ctx = extract_typed_pattern ctx fmt true false lv in + let ctx = extract_typed_pattern def.meta ctx fmt true false lv in ctx) ctx inputs_lvs in @@ -1543,7 +1545,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open a box for the body *) F.pp_open_hvbox fmt 0; (* Extract the body *) - let _ = extract_texpression ctx_body fmt false (Option.get def.body).body in + let _ = extract_texpression def.meta ctx_body fmt false (Option.get def.body).body in (* Close the box for the body *) F.pp_close_box fmt ()); (* Close the inner box for the definition *) @@ -1559,7 +1561,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* termination_by *) let terminates_name = - ctx_get_termination_measure def.def_id def.loop_id ctx + ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in F.pp_print_break fmt 0 0; (* Open a box for the whole [termination_by CALL => DECREASES] *) @@ -1572,7 +1574,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun v -> F.pp_print_space fmt (); - F.pp_print_string fmt (ctx_get_var v ctx_body)) + F.pp_print_string fmt (ctx_get_var def.meta v ctx_body)) all_vars; F.pp_print_space fmt (); F.pp_print_string fmt "=>"; @@ -1592,7 +1594,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun v -> F.pp_print_space fmt (); - F.pp_print_string fmt (ctx_get_var v ctx_body)) + F.pp_print_string fmt (ctx_get_var def.meta v ctx_body)) vars; (* Close the box for [DECREASES] *) F.pp_close_box fmt (); @@ -1602,7 +1604,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_break fmt 0 0; (* Open a box for the [decreasing by ...] *) F.pp_open_hvbox fmt ctx.indent_incr; - let decreases_name = ctx_get_decreases_proof def.def_id def.loop_id ctx in + let decreases_name = ctx_get_decreases_proof def.meta def.def_id def.loop_id ctx in F.pp_print_string fmt "decreasing_by"; F.pp_print_space fmt (); F.pp_open_hvbox fmt ctx.indent_incr; @@ -1610,7 +1612,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun v -> F.pp_print_space fmt (); - F.pp_print_string fmt (ctx_get_var v ctx_body)) + F.pp_print_string fmt (ctx_get_var def.meta v ctx_body)) vars; F.pp_close_box fmt (); (* Close the box for the [decreasing by ...] *) @@ -1640,12 +1642,12 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = (* Retrieve the definition name *) - let def_name = ctx_get_local_function def.def_id def.loop_id ctx in - assert (def.signature.generics.const_generics = []); + let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + cassert (def.signature.generics.const_generics = []) def.meta "TODO: error message"; (* Add the type/const gen parameters - note that we need those bindings only for the generation of the type (they are not top-level) *) let ctx, _, _, _ = - ctx_add_generic_params def.llbc_name def.signature.llbc_generics + ctx_add_generic_params def.meta def.llbc_name def.signature.llbc_generics def.signature.generics ctx in (* Add breaks to insert new lines between definitions *) @@ -1662,7 +1664,7 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "“:"; (* Generate the type *) extract_fun_input_parameters_types ctx fmt def; - extract_ty ctx fmt TypeDeclId.Set.empty false def.signature.output; + extract_ty def.meta ctx fmt TypeDeclId.Set.empty false def.signature.output; (* Close the box for the type *) F.pp_print_string fmt "”"; F.pp_close_box fmt (); @@ -1687,7 +1689,7 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - assert (not def.is_global_decl_body); + cassert (not def.is_global_decl_body) def.meta "TODO: error message"; (* We treat HOL4 opaque functions in a specific manner *) if !backend = HOL4 && Option.is_none def.body then extract_fun_decl_hol4_opaque ctx fmt def @@ -1700,7 +1702,7 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) extracted to two declarations, and we can actually factor out the generation of those declarations. See {!extract_global_decl} for more explanations. *) -let extract_global_decl_body_gen (ctx : extraction_ctx) (fmt : F.formatter) +let extract_global_decl_body_gen (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (name : string) (generics : generic_params) (type_params : string list) (cg_params : string list) (trait_clauses : string list) (ty : ty) @@ -1746,7 +1748,7 @@ let extract_global_decl_body_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open "TYPE" box (depth=3) *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print "TYPE" *) - extract_ty ctx fmt TypeDeclId.Set.empty false ty; + extract_ty meta ctx fmt TypeDeclId.Set.empty false ty; (* Close "TYPE" box (depth=3) *) F.pp_close_box fmt (); @@ -1792,7 +1794,7 @@ let extract_global_decl_body_gen (ctx : extraction_ctx) (fmt : F.formatter) Remark (SH): having to treat this specific case separately is very annoying, but I could not find a better way. *) -let extract_global_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) +let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (name : string) (generics : generic_params) (ty : ty) : unit = (* TODO: non-empty generics *) assert (generics = empty_generic_params); @@ -1805,7 +1807,7 @@ let extract_global_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt (); (* Print the type *) F.pp_open_hovbox fmt 0; - extract_ty ctx fmt TypeDeclId.Set.empty false ty; + extract_ty meta ctx fmt TypeDeclId.Set.empty false ty; (* Close the definition *) F.pp_print_string fmt ")"; F.pp_close_box fmt (); @@ -1836,8 +1838,8 @@ let extract_global_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : global_decl) (body : fun_decl) (interface : bool) : unit = - assert body.is_global_decl_body; - assert (body.signature.inputs = []); + cassert body.is_global_decl_body body.meta "TODO: Error message"; + cassert (body.signature.inputs = []) body.meta "TODO: Error message"; (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; @@ -1851,14 +1853,14 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) name global.meta.span; F.pp_print_space fmt (); - let decl_name = ctx_get_global global.def_id ctx in + let decl_name = ctx_get_global meta global.def_id ctx in let body_name = - ctx_get_function (FromLlbc (Pure.FunId (FRegular global.body_id), None)) ctx + ctx_get_function meta (FromLlbc (Pure.FunId (FRegular global.body_id), None)) ctx in let decl_ty, body_ty = let ty = body.signature.output in if body.signature.fwd_info.effect_info.can_fail then - (unwrap_result_ty ty, ty) + (unwrap_result_ty meta ty, ty) else (ty, mk_result_ty ty) in (* Add the type parameters *) @@ -1871,20 +1873,20 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (* No body: only generate a [val x_c : u32] declaration *) let kind = if interface then Declared else Assumed in if !backend = HOL4 then - extract_global_decl_hol4_opaque ctx fmt decl_name global.generics + extract_global_decl_hol4_opaque meta ctx fmt decl_name global.generics decl_ty else - extract_global_decl_body_gen ctx fmt kind decl_name global.generics + extract_global_decl_body_gen meta ctx fmt kind decl_name global.generics type_params cg_params trait_clauses decl_ty None | Some body -> (* There is a body *) (* Generate: [let x_body : result u32 = Return 3] *) - extract_global_decl_body_gen ctx fmt SingleNonRec body_name + extract_global_decl_body_gen meta ctx fmt SingleNonRec body_name global.generics type_params cg_params trait_clauses body_ty - (Some (fun fmt -> extract_texpression ctx fmt false body.body)); + (Some (fun fmt -> extract_texpression meta ctx fmt false body.body)); F.pp_print_break fmt 0 0; (* Generate: [let x_c : u32 = eval_global x_body] *) - extract_global_decl_body_gen ctx fmt SingleNonRec decl_name + extract_global_decl_body_gen meta ctx fmt SingleNonRec decl_name global.generics type_params cg_params trait_clauses decl_ty (Some (fun fmt -> @@ -1953,7 +1955,7 @@ let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (cid, cname) -> - ctx_add (TraitParentClauseId (trait_decl.def_id, cid)) cname ctx) + ctx_add trait_decl.meta (TraitParentClauseId (trait_decl.def_id, cid)) cname ctx) ctx clause_names (** Similar to {!extract_trait_decl_register_names} *) @@ -1986,7 +1988,7 @@ let extract_trait_decl_register_constant_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (item_name, name) -> - ctx_add (TraitItemId (trait_decl.def_id, item_name)) name ctx) + ctx_add trait_decl.meta (TraitItemId (trait_decl.def_id, item_name)) name ctx) ctx constant_names (** Similar to {!extract_trait_decl_register_names} *) @@ -2045,11 +2047,11 @@ let extract_trait_decl_type_names (ctx : extraction_ctx) List.fold_left (fun ctx (item_name, (type_name, clauses)) -> let ctx = - ctx_add (TraitItemId (trait_decl.def_id, item_name)) type_name ctx + ctx_add trait_decl.meta (TraitItemId (trait_decl.def_id, item_name)) type_name ctx in List.fold_left (fun ctx (clause_id, clause_name) -> - ctx_add + ctx_add trait_decl.meta (TraitItemClauseId (trait_decl.def_id, item_name, clause_id)) clause_name ctx) ctx clauses) @@ -2101,7 +2103,7 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (item_name, fun_name) -> - ctx_add (TraitMethodId (trait_decl.def_id, item_name)) fun_name ctx) + ctx_add trait_decl.meta (TraitMethodId (trait_decl.def_id, item_name)) fun_name ctx) ctx method_names (** Similar to {!extract_type_decl_register_names} *) @@ -2121,8 +2123,8 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) ctx_compute_trait_decl_constructor ctx trait_decl ) | Some info -> (info.extract_name, info.constructor) in - let ctx = ctx_add (TraitDeclId trait_decl.def_id) trait_name ctx in - ctx_add (TraitDeclConstructorId trait_decl.def_id) trait_constructor ctx + let ctx = ctx_add trait_decl.meta (TraitDeclId trait_decl.def_id) trait_name ctx in + ctx_add trait_decl.meta (TraitDeclConstructorId trait_decl.def_id) trait_constructor ctx in (* Parent clauses *) let ctx = @@ -2176,7 +2178,7 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) in (* For now we do not support overriding provided methods *) - assert (trait_impl.provided_methods = []); + cassert (trait_impl.provided_methods = []) trait_impl.meta "Overriding provided methods is not supported yet"; (* Everything is taken care of by {!extract_trait_decl_register_names} *but* the name of the implementation itself *) (* Compute the name *) @@ -2185,7 +2187,7 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) | None -> ctx_compute_trait_impl_name ctx trait_decl trait_impl | Some name -> name in - ctx_add (TraitImplId trait_impl.def_id) name ctx + ctx_add trait_decl.meta (TraitImplId trait_impl.def_id) name ctx (** Small helper. @@ -2250,7 +2252,7 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params f.llbc_name f.signature.llbc_generics generics ctx + ctx_add_generic_params f.meta f.llbc_name f.signature.llbc_generics generics ctx (* TODO: confirm it's the right meta*) in let backend_uses_forall = match !backend with Coq | Lean -> true | FStar | HOL4 -> false @@ -2259,9 +2261,9 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let use_forall = generics_not_empty && backend_uses_forall in let use_arrows = generics_not_empty && not backend_uses_forall in let use_forall_use_sep = false in - extract_generic_params ctx fmt TypeDeclId.Set.empty ~use_forall + extract_generic_params f.meta ctx fmt TypeDeclId.Set.empty ~use_forall ~use_forall_use_sep ~use_arrows generics type_params cg_params - trait_clauses; + trait_clauses; (* TODO: confirm it's the right meta*) if use_forall then F.pp_print_string fmt ","; (* Extract the inputs and output *) F.pp_print_space fmt (); @@ -2301,7 +2303,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for the name + generics *) F.pp_open_hovbox fmt ctx.indent_incr; let qualif = - Option.get (type_decl_kind_to_qualif SingleNonRec (Some Struct)) + Option.get (type_decl_kind_to_qualif decl.meta SingleNonRec (Some Struct)) in (* When checking if the trait declaration is empty: we ignore the provided methods, because for now they are extracted separately *) @@ -2317,9 +2319,9 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.llbc_name decl.llbc_generics generics ctx + ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics generics ctx in - extract_generic_params ctx fmt TypeDeclId.Set.empty generics type_params + extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty generics type_params cg_params trait_clauses; F.pp_print_space fmt (); @@ -2356,7 +2358,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) let ty () = let inside = false in F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty inside ty + extract_ty decl.meta ctx fmt TypeDeclId.Set.empty inside ty in extract_trait_decl_item ctx fmt item_name ty) decl.consts; @@ -2368,7 +2370,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) let item_name = ctx_get_trait_type decl.def_id name ctx in let ty () = F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword ()) + F.pp_print_string fmt (type_keyword decl.meta) in extract_trait_decl_item ctx fmt item_name ty; (* Extract the clauses *) @@ -2379,7 +2381,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) clauses) @@ -2394,7 +2396,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) decl.parent_clauses; @@ -2531,16 +2533,16 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, f_tys, f_cgs, f_tcs = - ctx_add_generic_params f.llbc_name f.signature.llbc_generics f_generics + ctx_add_generic_params f.meta f.llbc_name f.signature.llbc_generics f_generics ctx in let use_forall = f_generics <> empty_generic_params in - extract_generic_params ctx fmt TypeDeclId.Set.empty ~use_forall f_generics + extract_generic_params f.meta ctx fmt TypeDeclId.Set.empty ~use_forall f_generics f_tys f_cgs f_tcs; if use_forall then F.pp_print_string fmt ","; (* Extract the function call *) F.pp_print_space fmt (); - let fun_name = ctx_get_local_function f.def_id None ctx in + let fun_name = ctx_get_local_function f.meta f.def_id None ctx in F.pp_print_string fmt fun_name; let all_generics = let _, i_cgs, i_tcs = impl_generics in @@ -2556,7 +2558,9 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) in extract_trait_impl_item ctx fmt fun_name ty -(** Extract a trait implementation *) +(** Extract a trait implementation + * TODO: check if impl.meta everywhere is the right meta +*) let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (impl : trait_impl) : unit = log#ldebug (lazy ("extract_trait_impl: " ^ name_to_string ctx impl.llbc_name)); @@ -2602,17 +2606,17 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params impl.llbc_name impl.llbc_generics impl.generics ctx + ctx_add_generic_params impl.meta impl.llbc_name impl.llbc_generics impl.generics ctx in let all_generics = (type_params, cg_params, trait_clauses) in - extract_generic_params ctx fmt TypeDeclId.Set.empty impl.generics type_params + extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty impl.generics type_params cg_params trait_clauses; (* Print the type *) F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_trait_decl_ref ctx fmt TypeDeclId.Set.empty false impl.impl_trait; + extract_trait_decl_ref impl.meta ctx fmt TypeDeclId.Set.empty false impl.impl_trait; (* When checking if the trait impl is empty: we ignore the provided methods, because for now they are extracted separately *) @@ -2668,7 +2672,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - F.pp_print_string fmt (ctx_get_global id ctx); + F.pp_print_string fmt (ctx_get_global impl.meta id ctx); print_params () in @@ -2682,7 +2686,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) let item_name = ctx_get_trait_type trait_decl_id name ctx in let ty () = F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty false ty + extract_ty impl.meta ctx fmt TypeDeclId.Set.empty false ty in extract_trait_impl_item ctx fmt item_name ty; (* Extract the clauses *) @@ -2693,7 +2697,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false trait_ref in extract_trait_impl_item ctx fmt item_name ty) trait_refs) @@ -2707,7 +2711,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false trait_ref in extract_trait_impl_item ctx fmt item_name ty) impl.parent_trait_refs; @@ -2770,7 +2774,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "assert_norm"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.def_id def.loop_id ctx in + let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2778,13 +2782,13 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "="; F.pp_print_space fmt (); - let success = ctx_get_variant (TAssumed TResult) result_return_id ctx in + let success = ctx_get_variant def.meta (TAssumed TResult) result_return_id ctx in F.pp_print_string fmt (success ^ " ())") | Coq -> F.pp_print_string fmt "Check"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.def_id def.loop_id ctx in + let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2795,7 +2799,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "#assert"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.def_id def.loop_id ctx in + let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2803,12 +2807,12 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "=="; F.pp_print_space fmt (); - let success = ctx_get_variant (TAssumed TResult) result_return_id ctx in + let success = ctx_get_variant def.meta (TAssumed TResult) result_return_id ctx in F.pp_print_string fmt (success ^ " ())") | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; F.pp_print_string fmt "“"; - let fun_name = ctx_get_local_function def.def_id def.loop_id ctx in + let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 297a1d22..f6b891cc 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -7,6 +7,7 @@ open Config module F = Format open ExtractBuiltin open TranslateCore +open Errors (** The local logger *) let log = Logging.extract_log @@ -263,7 +264,7 @@ let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) in log#serror err; (* If we fail hard on errors, raise an exception *) - if !Config.fail_hard then raise (Failure err) + craise_opt_meta None err let names_map_get_id_from_name (name : string) (nm : names_map) : id option = StringMap.find_opt name nm.name_to_id @@ -297,7 +298,7 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) in log#serror err; (* If we fail hard on errors, raise an exception *) - if !Config.fail_hard then raise (Failure err)); + craise_opt_meta None err); (* Insert *) names_map_add_unchecked id name nm @@ -424,7 +425,7 @@ let names_maps_add (id_to_string : id -> string) (id : id) (name : string) (** The [id_to_string] function to print nice debugging messages if there are collisions *) -let names_maps_get (id_to_string : id -> string) (id : id) (nm : names_maps) : +let names_maps_get (meta : Meta.meta) (id_to_string : id -> string) (id : id) (nm : names_maps) : string = (* We do not use the same name map if we allow/disallow collisions *) let map_to_string (m : string IdMap.t) : string = @@ -445,7 +446,7 @@ let names_maps_get (id_to_string : id -> string) (id : id) (nm : names_maps) : ^ map_to_string m in log#serror err; - if !Config.fail_hard then raise (Failure err) + if !Config.fail_hard then craise meta err else "(%%%ERROR: unknown identifier\": " ^ id_to_string id ^ "\"%%%)") else let m = nm.names_map.id_to_name in @@ -457,7 +458,7 @@ let names_maps_get (id_to_string : id -> string) (id : id) (nm : names_maps) : ^ map_to_string m in log#serror err; - if !Config.fail_hard then raise (Failure err) + if !Config.fail_hard then craise meta err else "(ERROR: \"" ^ id_to_string id ^ "\")" type names_map_init = { @@ -528,6 +529,7 @@ let scalar_name (ty : literal_type) : string = functions, etc. *) type extraction_ctx = { + (* mutable _meta : Meta.meta; *) crate : A.crate; trans_ctx : trans_ctx; names_maps : names_maps; @@ -589,17 +591,17 @@ let llbc_fun_id_to_string (ctx : extraction_ctx) = let fun_id_to_string (ctx : extraction_ctx) = PrintPure.regular_fun_id_to_string (extraction_ctx_to_fmt_env ctx) -let adt_variant_to_string (ctx : extraction_ctx) = - PrintPure.adt_variant_to_string (extraction_ctx_to_fmt_env ctx) +let adt_variant_to_string (meta : Meta.meta) (ctx : extraction_ctx) = + PrintPure.adt_variant_to_string meta (extraction_ctx_to_fmt_env ctx) -let adt_field_to_string (ctx : extraction_ctx) = - PrintPure.adt_field_to_string (extraction_ctx_to_fmt_env ctx) +let adt_field_to_string (meta : Meta.meta) (ctx : extraction_ctx) = + PrintPure.adt_field_to_string meta (extraction_ctx_to_fmt_env ctx) (** Debugging function, used when communicating name collisions to the user, and also to print ids for internal debugging (in case of lookup miss for instance). *) -let id_to_string (id : id) (ctx : extraction_ctx) : string = +let id_to_string (meta : Meta.meta) (id : id) (ctx : extraction_ctx) : string = let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = let trait_name = trait_decl_id_to_string ctx id in "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" @@ -627,11 +629,11 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | StructId id -> "struct constructor of: " ^ type_id_to_string ctx id | VariantId (id, variant_id) -> let type_name = type_id_to_string ctx id in - let variant_name = adt_variant_to_string ctx id (Some variant_id) in + let variant_name = adt_variant_to_string meta ctx id (Some variant_id) in "type name: " ^ type_name ^ ", variant name: " ^ variant_name | FieldId (id, field_id) -> let type_name = type_id_to_string ctx id in - let field_name = adt_field_to_string ctx id field_id in + let field_name = adt_field_to_string meta ctx id field_id in "type name: " ^ type_name ^ ", field name: " ^ field_name | UnknownId -> "keyword" | TypeVarId id -> "type_var_id: " ^ TypeVarId.to_string id @@ -657,51 +659,55 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = trait_decl_id_to_string trait_decl_id ^ ", method name: " ^ fun_name | TraitSelfClauseId -> "trait_self_clause" -let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = - let id_to_string (id : id) : string = id_to_string id ctx in +let ctx_add (meta : Meta.meta) (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = + let id_to_string (id : id) : string = id_to_string meta id ctx in let names_maps = names_maps_add id_to_string id name ctx.names_maps in { ctx with names_maps } -let ctx_get (id : id) (ctx : extraction_ctx) : string = - let id_to_string (id : id) : string = id_to_string id ctx in - names_maps_get id_to_string id ctx.names_maps +let ctx_get (meta : Meta.meta) (id : id) (ctx : extraction_ctx) : string = + let id_to_string (id : id) : string = id_to_string meta id ctx in + names_maps_get meta id_to_string id ctx.names_maps (* TODO check if we can remove the meta arg, same for following functions*) -let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = - ctx_get (GlobalId id) ctx +let ctx_get_global (meta : Meta.meta) (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get meta (GlobalId id) ctx -let ctx_get_function (id : fun_id) (ctx : extraction_ctx) : string = - ctx_get (FunId id) ctx +let ctx_get_function (meta : Meta.meta) (id : fun_id) (ctx : extraction_ctx) : string = + ctx_get meta (FunId id) ctx -let ctx_get_local_function (id : A.FunDeclId.id) (lp : LoopId.id option) +let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) (lp : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get_function (FromLlbc (FunId (FRegular id), lp)) ctx + ctx_get_function meta (FromLlbc (FunId (FRegular id), lp)) ctx -let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = - assert (id <> TTuple); - ctx_get (TypeId id) ctx +let ctx_get_type (meta : Meta.meta) (id : type_id) (ctx : extraction_ctx) : string = + cassert (id <> TTuple) meta "T"; + ctx_get meta (TypeId id) ctx -let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = - ctx_get_type (TAdtId id) ctx +let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) (ctx : extraction_ctx) : string = + ctx_get_type meta (TAdtId id) ctx -let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = - ctx_get_type (TAssumed id) ctx +let ctx_get_assumed_type (meta : Meta.meta) (id : assumed_ty) (ctx : extraction_ctx) : string = + ctx_get_type meta (TAssumed id) ctx let ctx_get_trait_constructor (id : trait_decl_id) (ctx : extraction_ctx) : string = - ctx_get (TraitDeclConstructorId id) ctx + let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in + ctx_get meta (TraitDeclConstructorId id) ctx -let ctx_get_trait_self_clause (ctx : extraction_ctx) : string = - ctx_get TraitSelfClauseId ctx +let ctx_get_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : string = + ctx_get meta TraitSelfClauseId ctx let ctx_get_trait_decl (id : trait_decl_id) (ctx : extraction_ctx) : string = - ctx_get (TraitDeclId id) ctx + let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in + ctx_get meta (TraitDeclId id) ctx let ctx_get_trait_impl (id : trait_impl_id) (ctx : extraction_ctx) : string = - ctx_get (TraitImplId id) ctx + let meta = (TraitImplId.Map.find id ctx.trans_trait_impls).meta in + ctx_get meta (TraitImplId id) ctx let ctx_get_trait_item (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get (TraitItemId (id, item_name)) ctx + let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in + ctx_get meta (TraitItemId (id, item_name)) ctx let ctx_get_trait_const (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = @@ -713,48 +719,52 @@ let ctx_get_trait_type (id : trait_decl_id) (item_name : string) let ctx_get_trait_method (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get (TraitMethodId (id, item_name)) ctx + let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in + ctx_get meta (TraitMethodId (id, item_name)) ctx let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - ctx_get (TraitParentClauseId (id, clause)) ctx + let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in + ctx_get meta (TraitParentClauseId (id, clause)) ctx let ctx_get_trait_item_clause (id : trait_decl_id) (item : string) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - ctx_get (TraitItemClauseId (id, item, clause)) ctx + let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in + ctx_get meta (TraitItemClauseId (id, item, clause)) ctx -let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = - ctx_get (VarId id) ctx +let ctx_get_var (meta : Meta.meta) (id : VarId.id) (ctx : extraction_ctx) : string = + ctx_get meta (VarId id) ctx -let ctx_get_type_var (id : TypeVarId.id) (ctx : extraction_ctx) : string = - ctx_get (TypeVarId id) ctx +let ctx_get_type_var (meta : Meta.meta) (id : TypeVarId.id) (ctx : extraction_ctx) : string = + ctx_get meta (TypeVarId id) ctx -let ctx_get_const_generic_var (id : ConstGenericVarId.id) (ctx : extraction_ctx) +let ctx_get_const_generic_var (meta : Meta.meta) (id : ConstGenericVarId.id) (ctx : extraction_ctx) : string = - ctx_get (ConstGenericVarId id) ctx + ctx_get meta (ConstGenericVarId id) ctx -let ctx_get_local_trait_clause (id : TraitClauseId.id) (ctx : extraction_ctx) : +let ctx_get_local_trait_clause (meta : Meta.meta) (id : TraitClauseId.id) (ctx : extraction_ctx) : string = - ctx_get (LocalTraitClauseId id) ctx + ctx_get meta (LocalTraitClauseId id) ctx -let ctx_get_field (type_id : type_id) (field_id : FieldId.id) +let ctx_get_field (meta : Meta.meta) (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = - ctx_get (FieldId (type_id, field_id)) ctx + (* let meta = (TypeDeclId.Map.find type_id ctx.trans_types).meta in TODO : check how to get meta *) + ctx_get meta (FieldId (type_id, field_id)) ctx -let ctx_get_struct (def_id : type_id) (ctx : extraction_ctx) : string = - ctx_get (StructId def_id) ctx +let ctx_get_struct (meta : Meta.meta) (def_id : type_id) (ctx : extraction_ctx) : string = + ctx_get meta (StructId def_id) ctx -let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) +let ctx_get_variant (meta : Meta.meta) (def_id : type_id) (variant_id : VariantId.id) (ctx : extraction_ctx) : string = - ctx_get (VariantId (def_id, variant_id)) ctx + ctx_get meta (VariantId (def_id, variant_id)) ctx -let ctx_get_decreases_proof (def_id : A.FunDeclId.id) +let ctx_get_decreases_proof (meta : Meta.meta) (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get (DecreasesProofId (FRegular def_id, loop_id)) ctx + ctx_get meta (DecreasesProofId (FRegular def_id, loop_id)) ctx -let ctx_get_termination_measure (def_id : A.FunDeclId.id) +let ctx_get_termination_measure (meta : Meta.meta) (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get (TerminationMeasureId (FRegular def_id, loop_id)) ctx + ctx_get meta (TerminationMeasureId (FRegular def_id, loop_id)) ctx (** Small helper to compute the name of a unary operation *) let unop_name (unop : unop) : string = @@ -1161,7 +1171,7 @@ let initialize_names_maps () : names_maps = Remark: can return [None] for some backends like HOL4. *) -let type_decl_kind_to_qualif (kind : decl_kind) +let type_decl_kind_to_qualif (meta : Meta.meta) (kind : decl_kind) (type_kind : type_decl_kind option) : string option = match !backend with | FStar -> ( @@ -1189,11 +1199,11 @@ let type_decl_kind_to_qualif (kind : decl_kind) (* This is for traits *) Some "Record" | _ -> - raise - (Failure + craise + meta ("Unexpected: (" ^ show_decl_kind kind ^ ", " ^ Print.option_to_string show_type_decl_kind type_kind - ^ ")"))) + ^ ")")) | Lean -> ( match kind with | SingleNonRec -> ( @@ -1247,17 +1257,17 @@ let fun_decl_kind_to_qualif (kind : decl_kind) : string option = TODO: move inside the formatter? *) -let type_keyword () = +let type_keyword (meta : Meta.meta) = match !backend with | FStar -> "Type0" | Coq | Lean -> "Type" - | HOL4 -> raise (Failure "Unexpected") + | HOL4 -> craise meta "Unexpected" (** Helper *) -let name_last_elem_as_ident (n : llbc_name) : string = +let name_last_elem_as_ident (meta : Meta.meta) (n : llbc_name) : string = match Collections.List.last n with | PeIdent (s, _) -> s - | PeImpl _ -> raise (Failure "Unexpected") + | PeImpl _ -> craise meta "Unexpected" (** Helper @@ -1266,35 +1276,28 @@ let name_last_elem_as_ident (n : llbc_name) : string = we remove it. We ignore disambiguators (there may be collisions, but we check if there are). *) -let ctx_prepare_name (ctx : extraction_ctx) (name : llbc_name) : llbc_name = +let ctx_prepare_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : llbc_name = (* Rmk.: initially we only filtered the disambiguators equal to 0 *) match name with | (PeIdent (crate, _) as id) :: name -> if crate = ctx.crate.name then name else id :: name | _ -> - raise - (Failure + craise + meta ("Unexpected name shape: " ^ TranslateCore.name_to_string ctx.trans_ctx name)) -(** Helper *) -let ctx_compute_simple_name (ctx : extraction_ctx) (name : llbc_name) : - string list = - (* Rmk.: initially we only filtered the disambiguators equal to 0 *) - let name = ctx_prepare_name ctx name in - name_to_simple_name ctx.trans_ctx name - (** Helper *) let ctx_compute_simple_type_name = ctx_compute_simple_name (** Helper *) -let ctx_compute_type_name_no_suffix (ctx : extraction_ctx) (name : llbc_name) : +let ctx_compute_type_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : string = - flatten_name (ctx_compute_simple_type_name ctx name) + flatten_name (ctx_compute_simple_type_name meta ctx name) (** Provided a basename, compute a type name. *) -let ctx_compute_type_name (ctx : extraction_ctx) (name : llbc_name) = - let name = ctx_compute_type_name_no_suffix ctx name in +let ctx_compute_type_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) = + let name = ctx_compute_type_name_no_suffix meta ctx name in match !backend with | FStar -> StringUtils.lowercase_first_letter (name ^ "_t") | Coq | HOL4 -> name ^ "_t" @@ -1311,7 +1314,7 @@ let ctx_compute_type_name (ctx : extraction_ctx) (name : llbc_name) = access then causes trouble because not all provers accept syntax like [x.3] where [x] is a tuple. *) -let ctx_compute_field_name (ctx : extraction_ctx) (def_name : llbc_name) +let ctx_compute_field_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name : llbc_name) (field_id : FieldId.id) (field_name : string option) : string = let field_name_s = match field_name with @@ -1326,7 +1329,7 @@ let ctx_compute_field_name (ctx : extraction_ctx) (def_name : llbc_name) else field_name_s else let def_name = - ctx_compute_type_name_no_suffix ctx def_name ^ "_" ^ field_name_s + ctx_compute_type_name_no_suffix meta ctx def_name ^ "_" ^ field_name_s in match !backend with | Lean | HOL4 -> def_name @@ -1336,14 +1339,14 @@ let ctx_compute_field_name (ctx : extraction_ctx) (def_name : llbc_name) - type name - variant name *) -let ctx_compute_variant_name (ctx : extraction_ctx) (def_name : llbc_name) +let ctx_compute_variant_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name : llbc_name) (variant : string) : string = match !backend with | FStar | Coq | HOL4 -> let variant = to_camel_case variant in if !variant_concatenate_type_name then StringUtils.capitalize_first_letter - (ctx_compute_type_name_no_suffix ctx def_name ^ "_" ^ variant) + (ctx_compute_type_name_no_suffix meta ctx def_name ^ "_" ^ variant) else variant | Lean -> variant @@ -1358,14 +1361,14 @@ let ctx_compute_variant_name (ctx : extraction_ctx) (def_name : llbc_name) Inputs: - type name *) -let ctx_compute_struct_constructor (ctx : extraction_ctx) (basename : llbc_name) +let ctx_compute_struct_constructor (meta : Meta.meta) (ctx : extraction_ctx) (basename : llbc_name) : string = - let tname = ctx_compute_type_name ctx basename in + let tname = ctx_compute_type_name meta ctx basename in ExtractBuiltin.mk_struct_constructor tname -let ctx_compute_fun_name_no_suffix (ctx : extraction_ctx) (fname : llbc_name) : +let ctx_compute_fun_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (fname : llbc_name) : string = - let fname = ctx_compute_simple_name ctx fname in + let fname = ctx_compute_simple_name meta ctx fname in (* TODO: don't convert to snake case for Coq, HOL4, F* *) let fname = flatten_name fname in match !backend with @@ -1373,10 +1376,10 @@ let ctx_compute_fun_name_no_suffix (ctx : extraction_ctx) (fname : llbc_name) : | Lean -> fname (** Provided a basename, compute the name of a global declaration. *) -let ctx_compute_global_name (ctx : extraction_ctx) (name : llbc_name) : string = +let ctx_compute_global_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : string = match !Config.backend with | Coq | FStar | HOL4 -> - let parts = List.map to_snake_case (ctx_compute_simple_name ctx name) in + let parts = List.map to_snake_case (ctx_compute_simple_name meta ctx name) in String.concat "_" parts | Lean -> flatten_name (ctx_compute_simple_name ctx name) @@ -1395,7 +1398,7 @@ let default_fun_loop_suffix (num_loops : int) (loop_id : LoopId.id option) : (** A helper function: generates a function suffix. TODO: move all those helpers. *) -let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) : string = +let default_fun_suffix (meta : Meta.meta) (num_loops : int) (loop_id : LoopId.id option) : string = (* We only generate a suffix for the functions we generate from the loops *) default_fun_loop_suffix num_loops loop_id @@ -1409,17 +1412,17 @@ let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) : string = - loop id (if pertinent) TODO: use the fun id for the assumed functions. *) -let ctx_compute_fun_name (ctx : extraction_ctx) (fname : llbc_name) +let ctx_compute_fun_name (meta : Meta.meta) (ctx : extraction_ctx) (fname : llbc_name) (num_loops : int) (loop_id : LoopId.id option) : string = - let fname = ctx_compute_fun_name_no_suffix ctx fname in + let fname = ctx_compute_fun_name_no_suffix meta ctx fname in (* Compute the suffix *) - let suffix = default_fun_suffix num_loops loop_id in + let suffix = default_fun_suffix meta num_loops loop_id in (* Concatenate *) fname ^ suffix let ctx_compute_trait_decl_name (ctx : extraction_ctx) (trait_decl : trait_decl) : string = - ctx_compute_type_name ctx trait_decl.llbc_name + ctx_compute_type_name trait_decl.meta ctx trait_decl.llbc_name let ctx_compute_trait_impl_name (ctx : extraction_ctx) (trait_decl : trait_decl) (trait_impl : trait_impl) : string = @@ -1569,17 +1572,17 @@ let ctx_compute_trait_type_clause_name (ctx : extraction_ctx) the same purpose as in [llbc_name]. - loop identifier, if this is for a loop *) -let ctx_compute_termination_measure_name (ctx : extraction_ctx) +let ctx_compute_termination_measure_name (meta : Meta.meta) (ctx : extraction_ctx) (_fid : A.FunDeclId.id) (fname : llbc_name) (num_loops : int) (loop_id : LoopId.id option) : string = - let fname = ctx_compute_fun_name_no_suffix ctx fname in + let fname = ctx_compute_fun_name_no_suffix meta ctx fname in let lp_suffix = default_fun_loop_suffix num_loops loop_id in (* Compute the suffix *) let suffix = match !Config.backend with | FStar -> "_decreases" | Lean -> "_terminates" - | Coq | HOL4 -> raise (Failure "Unexpected") + | Coq | HOL4 -> craise meta "Unexpected" in (* Concatenate *) fname ^ lp_suffix ^ suffix @@ -1598,16 +1601,16 @@ let ctx_compute_termination_measure_name (ctx : extraction_ctx) the same purpose as in [llbc_name]. - loop identifier, if this is for a loop *) -let ctx_compute_decreases_proof_name (ctx : extraction_ctx) +let ctx_compute_decreases_proof_name (meta : Meta.meta) (ctx : extraction_ctx) (_fid : A.FunDeclId.id) (fname : llbc_name) (num_loops : int) (loop_id : LoopId.id option) : string = - let fname = ctx_compute_fun_name_no_suffix ctx fname in + let fname = ctx_compute_fun_name_no_suffix meta ctx fname in let lp_suffix = default_fun_loop_suffix num_loops loop_id in (* Compute the suffix *) let suffix = match !Config.backend with | Lean -> "_decreases" - | FStar | Coq | HOL4 -> raise (Failure "Unexpected") + | FStar | Coq | HOL4 -> craise meta "Unexpected" in (* Concatenate *) fname ^ lp_suffix ^ suffix @@ -1625,7 +1628,7 @@ let ctx_compute_decreases_proof_name (ctx : extraction_ctx) if necessary to prevent name clashes: the burden of name clashes checks is thus on the caller's side. *) -let ctx_compute_var_basename (ctx : extraction_ctx) (basename : string option) +let ctx_compute_var_basename (meta : Meta.meta) (ctx : extraction_ctx) (basename : string option) (ty : ty) : string = (* Small helper to derive var names from ADT type names. @@ -1638,7 +1641,7 @@ let ctx_compute_var_basename (ctx : extraction_ctx) (basename : string option) let cl = to_snake_case name in let cl = String.split_on_char '_' cl in let cl = List.filter (fun s -> String.length s > 0) cl in - assert (List.length cl > 0); + cassert (List.length cl > 0) meta "T"; let cl = List.map (fun s -> s.[0]) cl in StringUtils.string_of_chars cl in @@ -1738,82 +1741,82 @@ let name_append_index (basename : string) (i : int) : string = basename ^ string_of_int i (** Generate a unique type variable name and add it to the context *) -let ctx_add_type_var (basename : string) (id : TypeVarId.id) +let ctx_add_type_var (meta : Meta.meta) (basename : string) (id : TypeVarId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = ctx_compute_type_var_basename ctx basename in let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index name in - let ctx = ctx_add (TypeVarId id) name ctx in + let ctx = ctx_add meta (TypeVarId id) name ctx in (ctx, name) (** Generate a unique const generic variable name and add it to the context *) -let ctx_add_const_generic_var (basename : string) (id : ConstGenericVarId.id) +let ctx_add_const_generic_var (meta : Meta.meta) (basename : string) (id : ConstGenericVarId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = ctx_compute_const_generic_var_basename ctx basename in let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index name in - let ctx = ctx_add (ConstGenericVarId id) name ctx in + let ctx = ctx_add meta (ConstGenericVarId id) name ctx in (ctx, name) (** See {!ctx_add_type_var} *) -let ctx_add_type_vars (vars : (string * TypeVarId.id) list) +let ctx_add_type_vars (meta : Meta.meta) (vars : (string * TypeVarId.id) list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map - (fun ctx (name, id) -> ctx_add_type_var name id ctx) + (fun ctx (name, id) -> ctx_add_type_var meta name id ctx) ctx vars (** Generate a unique variable name and add it to the context *) -let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : +let ctx_add_var (meta : Meta.meta) (basename : string) (id : VarId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename in - let ctx = ctx_add (VarId id) name ctx in + let ctx = ctx_add meta (VarId id) name ctx in (ctx, name) (** Generate a unique variable name for the trait self clause and add it to the context *) -let ctx_add_trait_self_clause (ctx : extraction_ctx) : extraction_ctx * string = +let ctx_add_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : extraction_ctx * string = let basename = trait_self_clause_basename in let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename in - let ctx = ctx_add TraitSelfClauseId name ctx in + let ctx = ctx_add meta TraitSelfClauseId name ctx in (ctx, name) (** Generate a unique trait clause name and add it to the context *) -let ctx_add_local_trait_clause (basename : string) (id : TraitClauseId.id) +let ctx_add_local_trait_clause (meta : Meta.meta) (basename : string) (id : TraitClauseId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename in - let ctx = ctx_add (LocalTraitClauseId id) name ctx in + let ctx = ctx_add meta (LocalTraitClauseId id) name ctx in (ctx, name) (** See {!ctx_add_var} *) -let ctx_add_vars (vars : var list) (ctx : extraction_ctx) : +let ctx_add_vars (meta : Meta.meta) (vars : var list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (v : var) -> - let name = ctx_compute_var_basename ctx v.basename v.ty in - ctx_add_var name v.id ctx) + let name = ctx_compute_var_basename meta ctx v.basename v.ty in + ctx_add_var meta name v.id ctx) ctx vars -let ctx_add_type_params (vars : type_var list) (ctx : extraction_ctx) : +let ctx_add_type_params (meta : Meta.meta) (vars : type_var list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map - (fun ctx (var : type_var) -> ctx_add_type_var var.name var.index ctx) + (fun ctx (var : type_var) -> ctx_add_type_var meta var.name var.index ctx) ctx vars -let ctx_add_const_generic_params (vars : const_generic_var list) +let ctx_add_const_generic_params (meta : Meta.meta) (vars : const_generic_var list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (var : const_generic_var) -> - ctx_add_const_generic_var var.name var.index ctx) + ctx_add_const_generic_var meta var.name var.index ctx) ctx vars (** Returns the lists of names for: @@ -1825,7 +1828,7 @@ let ctx_add_const_generic_params (vars : const_generic_var list) pretty names for the trait clauses. See {!ctx_compute_trait_clause_name} for additional information. *) -let ctx_add_local_trait_clauses (current_def_name : Types.name) +let ctx_add_local_trait_clauses (meta : Meta.meta) (current_def_name : Types.name) (llbc_generics : Types.generic_params) (clauses : trait_clause list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map @@ -1834,7 +1837,7 @@ let ctx_add_local_trait_clauses (current_def_name : Types.name) ctx_compute_trait_clause_basename ctx current_def_name llbc_generics c.clause_id in - ctx_add_local_trait_clause basename c.clause_id ctx) + ctx_add_local_trait_clause meta basename c.clause_id ctx) ctx clauses (** Returns the lists of names for: @@ -1846,33 +1849,33 @@ let ctx_add_local_trait_clauses (current_def_name : Types.name) pretty names for the trait clauses. See {!ctx_compute_trait_clause_name} for additional information. *) -let ctx_add_generic_params (current_def_name : Types.name) +let ctx_add_generic_params (meta : Meta.meta) (current_def_name : Types.name) (llbc_generics : Types.generic_params) (generics : generic_params) (ctx : extraction_ctx) : extraction_ctx * string list * string list * string list = let { types; const_generics; trait_clauses } = generics in - let ctx, tys = ctx_add_type_params types ctx in - let ctx, cgs = ctx_add_const_generic_params const_generics ctx in + let ctx, tys = ctx_add_type_params meta types ctx in + let ctx, cgs = ctx_add_const_generic_params meta const_generics ctx in let ctx, tcs = - ctx_add_local_trait_clauses current_def_name llbc_generics trait_clauses ctx + ctx_add_local_trait_clauses meta current_def_name llbc_generics trait_clauses ctx in (ctx, tys, cgs, tcs) let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx_compute_decreases_proof_name ctx def.def_id def.llbc_name def.num_loops + ctx_compute_decreases_proof_name def.meta ctx def.def_id def.llbc_name def.num_loops def.loop_id in - ctx_add (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx + ctx_add def.meta (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx_compute_termination_measure_name ctx def.def_id def.llbc_name + ctx_compute_termination_measure_name def.meta ctx def.def_id def.llbc_name def.num_loops def.loop_id in - ctx_add (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx + ctx_add def.meta (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = @@ -1885,7 +1888,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : match match_name_find_opt ctx.trans_ctx def.name builtin_globals_map with | Some name -> (* Yes: register the custom binding *) - ctx_add decl name ctx + ctx_add def.meta decl name ctx | None -> (* Not the case: "standard" registration *) let name = ctx_compute_global_name ctx def.name in @@ -1903,20 +1906,20 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : let ctx_compute_fun_name (def : fun_decl) (ctx : extraction_ctx) : string = (* Add the function name *) - ctx_compute_fun_name ctx def.llbc_name def.num_loops def.loop_id + ctx_compute_fun_name def.meta ctx def.llbc_name def.num_loops def.loop_id (* TODO: move to Extract *) let ctx_add_fun_decl (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = (* Sanity check: the function should not be a global body - those are handled * separately *) - assert (not def.is_global_decl_body); + cassert (not def.is_global_decl_body) def.meta "The function should not be a global body - those are handled separately"; (* Lookup the LLBC def to compute the region group information *) let def_id = def.def_id in (* Add the function name *) let def_name = ctx_compute_fun_name def ctx in let fun_id = (Pure.FunId (FRegular def_id), def.loop_id) in - ctx_add (FunId (FromLlbc fun_id)) def_name ctx + ctx_add def.meta (FunId (FromLlbc fun_id)) def_name ctx let ctx_compute_type_decl_name (ctx : extraction_ctx) (def : type_decl) : string = - ctx_compute_type_name ctx def.llbc_name + ctx_compute_type_name def.meta ctx def.llbc_name diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index 80ed2ca3..9df5b03e 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -1,6 +1,7 @@ (** Utilities for extracting names *) open Charon.NameMatcher +open Errors let log = Logging.extract_log let match_with_trait_decl_refs = true @@ -31,7 +32,7 @@ end For impl blocks, we simply use the name of the type (without its arguments) if all the arguments are variables. *) -let pattern_to_extract_name (name : pattern) : string list = +let pattern_to_extract_name ?(meta = None) (name : pattern) : string list = let c = { tgt = TkName } in let all_vars = let check (g : generic_arg) : bool = @@ -71,7 +72,7 @@ let pattern_to_extract_name (name : pattern) : string list = let id = Collections.List.last id in match id with | PIdent (_, _) -> super#visit_PImpl () (EComp [ id ]) - | PImpl _ -> raise (Failure "Unreachable")) + | PImpl _ -> craise_opt_meta meta "Unreachable") | _ -> super#visit_PImpl () ty method! visit_EPrimAdt _ adt g = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index bbd5fae4..51ed7f5a 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -4,6 +4,7 @@ open Pure open PureUtils open TranslateCore open Config +open Errors include ExtractBase (** Format a constant value. @@ -14,7 +15,7 @@ include ExtractBase if it is made of an application (ex.: [U32 3]) - the constant value *) -let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit = +let extract_literal (meta : Meta.meta) (fmt : F.formatter) (inside : bool) (cv : literal) : unit = match cv with | VScalar sv -> ( match !backend with @@ -27,7 +28,7 @@ let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit = | HOL4 -> F.pp_print_string fmt ("int_to_" ^ int_name sv.int_ty); F.pp_print_space fmt () - | _ -> raise (Failure "Unreachable")); + | _ -> craise meta "Unreachable"); (* We need to add parentheses if the value is negative *) if sv.value >= Z.of_int 0 then F.pp_print_string fmt (Z.to_string sv.value) @@ -40,7 +41,7 @@ let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit = let iname = String.lowercase_ascii (int_name sv.int_ty) in F.pp_print_string fmt ("#" ^ iname) | HOL4 -> () - | _ -> raise (Failure "Unreachable")); + | _ -> craise meta "Unreachable"); if print_brackets then F.pp_print_string fmt ")") | VBool b -> let b = @@ -80,7 +81,7 @@ let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit = - unop - argument *) -let extract_unop (extract_expr : bool -> texpression -> unit) +let extract_unop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit = match unop with @@ -127,7 +128,7 @@ let extract_unop (extract_expr : bool -> texpression -> unit) match !backend with | Coq | FStar -> "scalar_cast" | Lean -> "Scalar.cast" - | HOL4 -> raise (Failure "Unreachable") + | HOL4 -> craise meta "Unreachable" in let src = if !backend <> Lean then Some (integer_type_to_string src) @@ -140,20 +141,20 @@ let extract_unop (extract_expr : bool -> texpression -> unit) match !backend with | Coq | FStar -> "scalar_cast_bool" | Lean -> "Scalar.cast_bool" - | HOL4 -> raise (Failure "Unreachable") + | HOL4 -> craise meta "Unreachable" in let tgt = integer_type_to_string tgt in (cast_str, None, Some tgt) | TInteger _, TBool -> (* This is not allowed by rustc: the way of doing it in Rust is: [x != 0] *) - raise (Failure "Unexpected cast: integer to bool") + craise meta "Unexpected cast: integer to bool" | TBool, TBool -> (* There shouldn't be any cast here. Note that if one writes [b as bool] in Rust (where [b] is a boolean), it gets compiled to [b] (i.e., no cast is introduced). *) - raise (Failure "Unexpected cast: bool to bool") - | _ -> raise (Failure "Unreachable") + craise meta "Unexpected cast: bool to bool" + | _ -> craise meta "Unreachable" in (* Print the name of the function *) F.pp_print_string fmt cast_str; @@ -186,7 +187,7 @@ let extract_unop (extract_expr : bool -> texpression -> unit) - argument 0 - argument 1 *) -let extract_binop (extract_expr : bool -> texpression -> unit) +let extract_binop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) (fmt : F.formatter) (inside : bool) (binop : E.binop) (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = if inside then F.pp_print_string fmt "("; @@ -231,7 +232,7 @@ let extract_binop (extract_expr : bool -> texpression -> unit) constant we need to provide the second implicit type argument *) if binop_is_shift && !backend = FStar && is_const arg1 then ( F.pp_print_space fmt (); - let ty = ty_as_integer arg1.ty in + let ty = ty_as_integer meta arg1.ty in F.pp_print_string fmt ("#" ^ StringUtils.capitalize_first_letter (int_name ty))); F.pp_print_space fmt (); @@ -272,7 +273,7 @@ let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) if is_single_opaque_fun_decl_group dg then () else let compute_fun_def_name (def : Pure.fun_decl) : string = - ctx_get_local_function def.def_id def.loop_id ctx ^ "_def" + ctx_get_local_function def.meta def.def_id def.loop_id ctx ^ "_def" in let names = List.map compute_fun_def_name dg in (* Add a break before *) @@ -391,15 +392,15 @@ let extract_arrow (fmt : F.formatter) () : unit = if !Config.backend = Lean then F.pp_print_string fmt "→" else F.pp_print_string fmt "->" -let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) +let extract_const_generic (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (cg : const_generic) : unit = match cg with | CgGlobal id -> - let s = ctx_get_global id ctx in + let s = ctx_get_global meta id ctx in F.pp_print_string fmt s - | CgValue v -> extract_literal fmt inside v + | CgValue v -> extract_literal meta fmt inside v | CgVar id -> - let s = ctx_get_const_generic_var id ctx in + let s = ctx_get_const_generic_var meta id ctx in F.pp_print_string fmt s let extract_literal_type (_ctx : extraction_ctx) (fmt : F.formatter) @@ -429,9 +430,9 @@ let extract_literal_type (_ctx : extraction_ctx) (fmt : F.formatter) End ]} *) -let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) +let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (ty : ty) : unit = - let extract_rec = extract_ty ctx fmt no_params_tys in + let extract_rec = extract_ty meta ctx fmt no_params_tys in match ty with | TAdt (type_id, generics) -> ( let has_params = generics <> empty_generic_args in @@ -469,7 +470,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) if print_paren then F.pp_print_string fmt "("; (* TODO: for now, only the opaque *functions* are extracted in the opaque module. The opaque *types* are assumed. *) - F.pp_print_string fmt (ctx_get_type type_id ctx); + F.pp_print_string fmt (ctx_get_type meta type_id ctx); (* We might need to filter the type arguments, if the type is builtin (for instance, we filter the global allocator type argument for `Vec`). *) @@ -490,7 +491,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) { generics with types }) | _ -> generics in - extract_generic_args ctx fmt no_params_tys generics; + extract_generic_args meta ctx fmt no_params_tys generics; if print_paren then F.pp_print_string fmt ")" | HOL4 -> let { types; const_generics; trait_refs } = generics in @@ -500,7 +501,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) match type_id with | TAdtId id -> not (TypeDeclId.Set.mem id no_params_tys) | TAssumed _ -> true - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in if types <> [] && print_tys then ( let print_paren = List.length types > 1 in @@ -512,13 +513,13 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (extract_rec true) types; if print_paren then F.pp_print_string fmt ")"; F.pp_print_space fmt ()); - F.pp_print_string fmt (ctx_get_type type_id ctx); + F.pp_print_string fmt (ctx_get_type meta type_id ctx); if trait_refs <> [] then ( F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) - (extract_trait_ref ctx fmt no_params_tys true) + (extract_trait_ref meta ctx fmt no_params_tys true) trait_refs))) - | TVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) + | TVar vid -> F.pp_print_string fmt (ctx_get_type_var meta vid ctx) | TLiteral lty -> extract_literal_type ctx fmt lty | TArrow (arg_ty, ret_ty) -> if inside then F.pp_print_string fmt "("; @@ -529,7 +530,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) extract_rec false ret_ty; if inside then F.pp_print_string fmt ")" | TTraitType (trait_ref, type_name) -> ( - if !parameterize_trait_types then raise (Failure "Unimplemented") + if !parameterize_trait_types then craise meta "Unimplemented" else let type_name = ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name @@ -548,16 +549,16 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) match trait_ref.trait_id with | Self -> assert (trait_ref.generics = empty_generic_args); - extract_trait_instance_id_with_dot ctx fmt no_params_tys false + extract_trait_instance_id_with_dot meta ctx fmt no_params_tys false trait_ref.trait_id; F.pp_print_string fmt type_name | _ -> (* HOL4 doesn't have 1st class types *) assert (!backend <> HOL4); - extract_trait_ref ctx fmt no_params_tys false trait_ref; + extract_trait_ref meta ctx fmt no_params_tys false trait_ref; F.pp_print_string fmt ("." ^ add_brackets type_name)) -and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) +and extract_trait_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = let use_brackets = tr.generics <> empty_generic_args && inside in if use_brackets then F.pp_print_string fmt "("; @@ -578,11 +579,11 @@ and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) { tr.generics with types }) | _ -> tr.generics in - extract_trait_instance_id ctx fmt no_params_tys inside tr.trait_id; - extract_generic_args ctx fmt no_params_tys generics; + extract_trait_instance_id meta ctx fmt no_params_tys inside tr.trait_id; + extract_generic_args meta ctx fmt no_params_tys generics; if use_brackets then F.pp_print_string fmt ")" -and extract_trait_decl_ref (ctx : extraction_ctx) (fmt : F.formatter) +and extract_trait_decl_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_decl_ref) : unit = let use_brackets = tr.decl_generics <> empty_generic_args && inside in @@ -592,28 +593,28 @@ and extract_trait_decl_ref (ctx : extraction_ctx) (fmt : F.formatter) (* There is something subtle here: the trait obligations for the implemented trait are put inside the parent clauses, so we must ignore them here *) let generics = { tr.decl_generics with trait_refs = [] } in - extract_generic_args ctx fmt no_params_tys generics; + extract_generic_args meta ctx fmt no_params_tys generics; if use_brackets then F.pp_print_string fmt ")" -and extract_generic_args (ctx : extraction_ctx) (fmt : F.formatter) +and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (generics : generic_args) : unit = let { types; const_generics; trait_refs } = generics in if !backend <> HOL4 then ( if types <> [] then ( F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) - (extract_ty ctx fmt no_params_tys true) + (extract_ty meta ctx fmt no_params_tys true) types); if const_generics <> [] then ( assert (!backend <> HOL4); F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) - (extract_const_generic ctx fmt true) + (extract_const_generic meta ctx fmt true) const_generics)); if trait_refs <> [] then ( F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) - (extract_trait_ref ctx fmt no_params_tys true) + (extract_trait_ref meta ctx fmt no_params_tys true) trait_refs) (** We sometimes need to ignore references to `Self` when generating the @@ -622,7 +623,7 @@ and extract_generic_args (ctx : extraction_ctx) (fmt : F.formatter) id (e.g., `::foo` - note that in the extracted code, the projections are often written with a dot '.'). *) -and extract_trait_instance_id_with_dot (ctx : extraction_ctx) +and extract_trait_instance_id_with_dot (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) : unit = match id with @@ -641,7 +642,7 @@ and extract_trait_instance_id_with_dot (ctx : extraction_ctx) *) if ctx.is_provided_method then (* Provided method: use the trait self clause *) - let self_clause = ctx_get_trait_self_clause ctx in + let self_clause = ctx_get_trait_self_clause meta ctx in F.pp_print_string fmt (self_clause ^ ".") else (* Declaration: nothing to print, we will directly refer to @@ -649,10 +650,10 @@ and extract_trait_instance_id_with_dot (ctx : extraction_ctx) () | _ -> (* Other cases *) - extract_trait_instance_id ctx fmt no_params_tys inside id; + extract_trait_instance_id meta ctx fmt no_params_tys inside id; F.pp_print_string fmt "." -and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) +and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) : unit = let add_brackets (s : string) = if !backend = Coq then "(" ^ s ^ ")" else s in @@ -661,29 +662,29 @@ and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) (* This has a specific treatment depending on the item we're extracting (associated type, etc.). We should have caught this elsewhere. *) if !Config.fail_hard then - raise (Failure "Unexpected occurrence of `Self`") + craise meta "Unexpected occurrence of `Self`" else F.pp_print_string fmt "ERROR(\"Unexpected Self\")" | TraitImpl id -> let name = ctx_get_trait_impl id ctx in F.pp_print_string fmt name | Clause id -> - let name = ctx_get_local_trait_clause id ctx in + let name = ctx_get_local_trait_clause meta id ctx in F.pp_print_string fmt name | ParentClause (inst_id, decl_id, clause_id) -> (* Use the trait decl id to lookup the name *) let name = ctx_get_trait_parent_clause decl_id clause_id ctx in - extract_trait_instance_id_with_dot ctx fmt no_params_tys true inst_id; + extract_trait_instance_id_with_dot meta ctx fmt no_params_tys true inst_id; F.pp_print_string fmt (add_brackets name) | ItemClause (inst_id, decl_id, item_name, clause_id) -> (* Use the trait decl id to lookup the name *) let name = ctx_get_trait_item_clause decl_id item_name clause_id ctx in - extract_trait_instance_id_with_dot ctx fmt no_params_tys true inst_id; + extract_trait_instance_id_with_dot meta ctx fmt no_params_tys true inst_id; F.pp_print_string fmt (add_brackets name) | TraitRef trait_ref -> - extract_trait_ref ctx fmt no_params_tys inside trait_ref + extract_trait_ref meta ctx fmt no_params_tys inside trait_ref | UnknownTrait _ -> (* This is an error case *) - raise (Failure "Unexpected") + craise meta "Unexpected" (** Compute the names for all the top-level identifiers used in a type definition (type name, variant names, field names, etc. but not type @@ -713,10 +714,10 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : (* Compute and register the type def name *) let def_name = match info with - | None -> ctx_compute_type_name ctx def.llbc_name + | None -> ctx_compute_type_name def.meta ctx def.llbc_name | Some info -> info.extract_name in - let ctx = ctx_add (TypeId (TAdtId def.def_id)) def_name ctx in + let ctx = ctx_add def.meta (TypeId (TAdtId def.def_id)) def_name ctx in (* Compute and register: * - the variant names, if this is an enumeration * - the field names, if this is a structure @@ -738,12 +739,12 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : FieldId.mapi (fun fid (field : field) -> ( fid, - ctx_compute_field_name ctx def.llbc_name fid + ctx_compute_field_name def.meta ctx def.llbc_name fid field.field_name )) fields in let cons_name = - ctx_compute_struct_constructor ctx def.llbc_name + ctx_compute_struct_constructor def.meta ctx def.llbc_name in (field_names, cons_name) | Some { body_info = Some (Struct (cons_name, field_names)); _ } -> @@ -760,20 +761,20 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : in (field_names, cons_name) | Some info -> - raise - (Failure + craise + def.meta ("Invalid builtin information: " - ^ show_builtin_type_info info)) + ^ show_builtin_type_info info) in (* Add the fields *) let ctx = List.fold_left (fun ctx (fid, name) -> - ctx_add (FieldId (TAdtId def.def_id, fid)) name ctx) + ctx_add def.meta (FieldId (TAdtId def.def_id, fid)) name ctx) ctx field_names in (* Add the constructor name *) - ctx_add (StructId (TAdtId def.def_id)) cons_name ctx + ctx_add def.meta (StructId (TAdtId def.def_id)) cons_name ctx | Enum variants -> let variant_names = match info with @@ -781,14 +782,14 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : VariantId.mapi (fun variant_id (variant : variant) -> let name = - ctx_compute_variant_name ctx def.llbc_name + ctx_compute_variant_name def.meta ctx def.llbc_name variant.variant_name in (* Add the type name prefix for Lean *) let name = if !Config.backend = Lean then let type_name = - ctx_compute_type_name ctx def.llbc_name + ctx_compute_type_name def.meta ctx def.llbc_name in type_name ^ "." ^ name else name @@ -808,11 +809,11 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : (fun variant_id (variant : variant) -> (variant_id, StringMap.find variant.variant_name variant_map)) variants - | _ -> raise (Failure "Invalid builtin information") + | _ -> craise def.meta "Invalid builtin information" in List.fold_left (fun ctx (vid, vname) -> - ctx_add (VariantId (TAdtId def.def_id, vid)) vname ctx) + ctx_add def.meta (VariantId (TAdtId def.def_id, vid)) vname ctx) ctx variant_names | Opaque -> (* Nothing to do *) @@ -822,7 +823,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : ctx (** Print the variants *) -let extract_type_decl_variant (ctx : extraction_ctx) (fmt : F.formatter) +let extract_type_decl_variant (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (type_decl_group : TypeDeclId.Set.t) (type_name : string) (type_params : string list) (cg_params : string list) (cons_name : string) (fields : field list) : unit = @@ -851,9 +852,9 @@ let extract_type_decl_variant (ctx : extraction_ctx) (fmt : F.formatter) | Some field_name -> let var_id = VarId.of_int (FieldId.to_int fid) in let field_name = - ctx_compute_var_basename ctx (Some field_name) f.field_ty + ctx_compute_var_basename meta ctx (Some field_name) f.field_ty in - let ctx, field_name = ctx_add_var field_name var_id ctx in + let ctx, field_name = ctx_add_var meta field_name var_id ctx in F.pp_print_string fmt (field_name ^ " :"); F.pp_print_space fmt (); ctx) @@ -861,7 +862,7 @@ let extract_type_decl_variant (ctx : extraction_ctx) (fmt : F.formatter) in (* Print the field type *) let inside = !backend = HOL4 in - extract_ty ctx fmt type_decl_group inside f.field_ty; + extract_ty meta ctx fmt type_decl_group inside f.field_ty; (* Print the arrow [->] *) if !backend <> HOL4 then ( F.pp_print_space fmt (); @@ -932,9 +933,9 @@ let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) let print_variant _variant_id (v : variant) = (* We don't lookup the name, because it may have a prefix for the type id (in the case of Lean) *) - let cons_name = ctx_compute_variant_name ctx def.llbc_name v.variant_name in + let cons_name = ctx_compute_variant_name def.meta ctx def.llbc_name v.variant_name in let fields = v.fields in - extract_type_decl_variant ctx fmt type_decl_group def_name type_params + extract_type_decl_variant def.meta ctx fmt type_decl_group def_name type_params cg_params cons_name fields in (* Print the variants *) @@ -942,7 +943,7 @@ let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun (vid, v) -> print_variant vid v) variants (** Extract a struct as a tuple *) -let extract_type_decl_tuple_struct_body (ctx : extraction_ctx) +let extract_type_decl_tuple_struct_body (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (fields : field list) : unit = (* If the type is empty, we need to have a special treatment *) if fields = [] then ( @@ -956,7 +957,7 @@ let extract_type_decl_tuple_struct_body (ctx : extraction_ctx) F.pp_print_string fmt sep) (fun (f : field) -> F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty true f.field_ty) + extract_ty meta ctx fmt TypeDeclId.Set.empty true f.field_ty) fields let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) @@ -1032,7 +1033,7 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) (* If Coq: print the constructor name *) (* TODO: remove superfluous test not is_rec below *) if !backend = Coq && not is_rec then ( - F.pp_print_string fmt (ctx_get_struct (TAdtId def.def_id) ctx); + F.pp_print_string fmt (ctx_get_struct def.meta (TAdtId def.def_id) ctx); F.pp_print_string fmt " "); (match !backend with | Lean -> () @@ -1046,14 +1047,14 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) | Lean -> F.pp_open_vbox fmt 0); (* Print the fields *) let print_field (field_id : FieldId.id) (f : field) : unit = - let field_name = ctx_get_field (TAdtId def.def_id) field_id ctx in + let field_name = ctx_get_field def.meta (TAdtId def.def_id) field_id ctx in (* Open a box for the field *) F.pp_open_box fmt ctx.indent_incr; F.pp_print_string fmt field_name; F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_ty ctx fmt type_decl_group false f.field_ty; + extract_ty def.meta ctx fmt type_decl_group false f.field_ty; if !backend <> Lean then F.pp_print_string fmt ";"; (* Close the box for the field *) F.pp_close_box fmt () @@ -1081,10 +1082,10 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) i.e., instead of generating `inductive Foo := | MkFoo ...` like in Coq we generate `inductive Foo := | mk ... *) let cons_name = - if !backend = Lean then "mk" else ctx_get_struct (TAdtId def.def_id) ctx + if !backend = Lean then "mk" else ctx_get_struct def.meta (TAdtId def.def_id) ctx in - let def_name = ctx_get_local_type def.def_id ctx in - extract_type_decl_variant ctx fmt type_decl_group def_name type_params + let def_name = ctx_get_local_type def.meta def.def_id ctx in + extract_type_decl_variant def.meta ctx fmt type_decl_group def_name type_params cg_params cons_name fields) in () @@ -1129,11 +1130,11 @@ let extract_comment_with_span (ctx : extraction_ctx) (fmt : F.formatter) in extract_comment fmt (sl @ [ span ] @ name) -let extract_trait_clause_type (ctx : extraction_ctx) (fmt : F.formatter) +let extract_trait_clause_type meta (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = let trait_name = ctx_get_trait_decl clause.trait_id ctx in F.pp_print_string fmt trait_name; - extract_generic_args ctx fmt no_params_tys clause.generics + extract_generic_args meta ctx fmt no_params_tys clause.generics (** Insert a space, if necessary *) let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = @@ -1148,7 +1149,7 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) (params : string list) : unit = insert_req_space (); F.pp_print_string fmt "("; - let self_clause = ctx_get_trait_self_clause ctx in + let self_clause = ctx_get_trait_self_clause trait_decl.meta ctx in F.pp_print_string fmt self_clause; F.pp_print_space fmt (); F.pp_print_string fmt ":"; @@ -1166,7 +1167,7 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) - [trait_decl]: if [Some], it means we are extracting the generics for a provided method and need to insert a trait self clause (see {!TraitSelfClauseId}). *) -let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) +let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) ?(use_forall_use_sep = true) ?(use_arrows = false) ?(as_implicits : bool = false) ?(space : bool ref option = None) @@ -1219,7 +1220,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) type_params; F.pp_print_string fmt ":"; F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword ()); + F.pp_print_string fmt (type_keyword meta); (* ) *) right_bracket as_implicits; if use_arrows then ( @@ -1231,7 +1232,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) insert_req_space (); (* ( *) left_bracket as_implicits; - let n = ctx_get_const_generic_var var.index ctx in + let n = ctx_get_const_generic_var meta var.index ctx in print_implicit_symbol as_implicits; F.pp_print_string fmt n; F.pp_print_space fmt (); @@ -1250,13 +1251,13 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) insert_req_space (); (* ( *) left_bracket as_implicits; - let n = ctx_get_local_trait_clause clause.clause_id ctx in + let n = ctx_get_local_trait_clause meta clause.clause_id ctx in print_implicit_symbol as_implicits; F.pp_print_string fmt n; F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt no_params_tys clause; + extract_trait_clause_type meta ctx fmt no_params_tys clause; (* ) *) right_bracket as_implicits; if use_arrows then ( @@ -1300,10 +1301,10 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) dtype_params; map (fun (cg : const_generic_var) -> - ctx_get_const_generic_var cg.index ctx) + ctx_get_const_generic_var trait_decl.meta cg.index ctx) dcgs; map - (fun c -> ctx_get_local_trait_clause c.clause_id ctx) + (fun c -> ctx_get_local_trait_clause trait_decl.meta c.clause_id ctx) dtrait_clauses; ] in @@ -1350,11 +1351,11 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let is_opaque_coq = !backend = Coq && is_opaque in let use_forall = is_opaque_coq && def.generics <> empty_generic_params in (* Retrieve the definition name *) - let def_name = ctx_get_local_type def.def_id ctx in + let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx_body, type_params, cg_params, trait_clauses = - ctx_add_generic_params def.llbc_name def.llbc_generics def.generics ctx + ctx_add_generic_params def.meta def.llbc_name def.llbc_generics def.generics ctx in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then @@ -1387,7 +1388,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt ()) else (); (* > "type TYPE_NAME" *) - let qualif = type_decl_kind_to_qualif kind type_kind in + let qualif = type_decl_kind_to_qualif def.meta kind type_kind in (match qualif with | Some qualif -> F.pp_print_string fmt (qualif ^ " " ^ def_name) | None -> F.pp_print_string fmt def_name); @@ -1395,7 +1396,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) support trait clauses *) assert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4); (* Print the generic parameters *) - extract_generic_params ctx_body fmt type_decl_group ~use_forall def.generics + extract_generic_params def.meta ctx_body fmt type_decl_group ~use_forall def.generics type_params cg_params trait_clauses; (* Print the "=" if we extract the body*) if extract_body then ( @@ -1422,21 +1423,21 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt ":"); F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword ())); + F.pp_print_string fmt (type_keyword def.meta)); (* Close the box for "type TYPE_NAME (TYPE_PARAMS) =" *) F.pp_close_box fmt (); (if extract_body then match def.kind with | Struct fields -> if is_tuple_struct then - extract_type_decl_tuple_struct_body ctx_body fmt fields + extract_type_decl_tuple_struct_body def.meta ctx_body fmt fields else extract_type_decl_struct_body ctx_body fmt type_decl_group kind def type_params cg_params fields | Enum variants -> extract_type_decl_enum_body ctx_body fmt type_decl_group def def_name type_params cg_params variants - | Opaque -> raise (Failure "Unreachable")); + | Opaque -> craise def.meta "Unreachable"); (* Add the definition end delimiter *) if !backend = HOL4 && decl_is_not_last_from_group kind then ( F.pp_print_space fmt (); @@ -1460,7 +1461,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : type_decl) : unit = (* Retrieve the definition name *) - let def_name = ctx_get_local_type def.def_id ctx in + let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Generic parameters are unsupported *) assert (def.generics.const_generics = []); (* Trait clauses on type definitions are unsupported *) @@ -1485,7 +1486,7 @@ let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) (fmt : F.formatter) (def : type_decl) : unit = (* Retrieve the definition name *) - let def_name = ctx_get_local_type def.def_id ctx in + let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Sanity check *) assert (def.generics = empty_generic_params); (* Generate the declaration *) @@ -1578,14 +1579,14 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) | Struct fields -> let adt_id = TAdtId decl.def_id in (* Generate the instruction for the record constructor *) - let cons_name = ctx_get_struct adt_id ctx in + let cons_name = ctx_get_struct decl.meta adt_id ctx in extract_coq_arguments_instruction ctx fmt cons_name num_params; (* Generate the instruction for the record projectors, if there are *) let is_rec = decl_is_from_rec_group kind in if not is_rec then FieldId.iteri (fun fid _ -> - let cons_name = ctx_get_field adt_id fid ctx in + let cons_name = ctx_get_field decl.meta adt_id fid ctx in extract_coq_arguments_instruction ctx fmt cons_name num_params) fields; (* Add breaks to insert new lines between definitions *) @@ -1594,7 +1595,7 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (* Generate the instructions *) VariantId.iteri (fun vid (_ : variant) -> - let cons_name = ctx_get_variant (TAdtId decl.def_id) vid ctx in + let cons_name = ctx_get_variant decl.meta (TAdtId decl.def_id) vid ctx in extract_coq_arguments_instruction ctx fmt cons_name num_params) variants; (* Add breaks to insert new lines between definitions *) @@ -1618,13 +1619,13 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) if is_rec then (* Add the type params *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.llbc_name decl.llbc_generics decl.generics + ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics decl.generics ctx in - let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in - let ctx, field_var = ctx_add_var "x" (VarId.of_int 1) ctx in - let def_name = ctx_get_local_type decl.def_id ctx in - let cons_name = ctx_get_struct (TAdtId decl.def_id) ctx in + let ctx, record_var = ctx_add_var decl.meta "x" (VarId.of_int 0) ctx in + let ctx, field_var = ctx_add_var decl.meta "x" (VarId.of_int 1) ctx in + let def_name = ctx_get_local_type decl.meta decl.def_id ctx in + let cons_name = ctx_get_struct decl.meta (TAdtId decl.def_id) ctx in let extract_field_proj (field_id : FieldId.id) (_ : field) : unit = F.pp_print_space fmt (); (* Outer box for the projector definition *) @@ -1635,11 +1636,11 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) F.pp_open_hovbox fmt ctx.indent_incr; F.pp_print_string fmt "Definition"; F.pp_print_space fmt (); - let field_name = ctx_get_field (TAdtId decl.def_id) field_id ctx in + let field_name = ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx in F.pp_print_string fmt field_name; (* Print the generics *) let as_implicits = true in - extract_generic_params ctx fmt TypeDeclId.Set.empty ~as_implicits + extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty ~as_implicits decl.generics type_params cg_params trait_clauses; (* Print the record parameter *) F.pp_print_space fmt (); @@ -1715,10 +1716,10 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) F.pp_open_hvbox fmt 0; (* Inner box for the projector definition *) F.pp_open_hovbox fmt ctx.indent_incr; - let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in + let ctx, record_var = ctx_add_var decl.meta "x" (VarId.of_int 0) ctx in F.pp_print_string fmt "Notation"; F.pp_print_space fmt (); - let field_name = ctx_get_field (TAdtId decl.def_id) field_id ctx in + let field_name = ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx in F.pp_print_string fmt ("\"" ^ record_var ^ " .(" ^ field_name ^ ")\""); F.pp_print_space fmt (); F.pp_print_string fmt ":="; @@ -1769,7 +1770,7 @@ let extract_type_decl_extra_info (ctx : extraction_ctx) (fmt : F.formatter) extract_type_decl_record_field_projectors ctx fmt kind decl) (** Extract the state type declaration. *) -let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) +let extract_state_type (meta : Meta.meta) (fmt : F.formatter) (ctx : extraction_ctx) (kind : decl_kind) : unit = (* Add a break before *) F.pp_print_break fmt 0 0; @@ -1780,14 +1781,14 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) * one line *) F.pp_open_hvbox fmt 0; (* Retrieve the name *) - let state_name = ctx_get_assumed_type TState ctx in + let state_name = ctx_get_assumed_type meta TState ctx in (* The syntax for Lean and Coq is almost identical. *) let print_axiom () = let axiom = match !backend with | Coq -> "Axiom" | Lean -> "axiom" - | FStar | HOL4 -> raise (Failure "Unexpected") + | FStar | HOL4 -> craise meta "Unexpected" in F.pp_print_string fmt axiom; F.pp_print_space fmt (); @@ -1801,7 +1802,7 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) (* The kind should be [Assumed] or [Declared] *) (match kind with | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> - raise (Failure "Unexpected") + craise meta "Unexpected" | Assumed -> ( match !backend with | FStar -> diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index f6976f23..14185a3d 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -9,6 +9,7 @@ open LlbcAst open ExpressionsUtils +open Errors (** Various information about a function. @@ -36,7 +37,6 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) (globals_map : global_decl GlobalDeclId.Map.t) (use_state : bool) : modules_funs_info = let infos = ref FunDeclId.Map.empty in - let register_info (id : FunDeclId.id) (info : fun_info) : unit = assert (not (FunDeclId.Map.mem id !infos)); infos := FunDeclId.Map.add id info !infos @@ -119,7 +119,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) method! visit_Call env call = (match call.func with | FnOpMove _ -> - (* Ignoring this: we lookup the called function upon creating + (* Ignoring this: we lookup t he called function upon creating the closure *) () | FnOpRegular func -> ( @@ -145,7 +145,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) end in (* Sanity check: global bodies don't contain stateful calls *) - assert ((not f.is_global_decl_body) || not !stateful); + cassert ((not f.is_global_decl_body) || not !stateful) f.meta "Global bodies should not contain stateful calls"; let builtin_info = get_builtin_info f in let has_builtin_info = builtin_info <> None in group_has_builtin_info := !group_has_builtin_info || has_builtin_info; @@ -167,8 +167,8 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) (* We need to know if the declaration group contains a global - note that * groups containing globals contain exactly one declaration *) let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in - assert ((not is_global_decl_body) || List.length d = 1); - assert ((not !group_has_builtin_info) || List.length d = 1); + cassert ((not is_global_decl_body) || List.length d = 1) (List.hd d).meta "The declaration group should containing globals should contain exactly one declaration"; (*TODO recheck how to get meta*) + cassert ((not !group_has_builtin_info) || List.length d = 1) (List.hd d).meta "The declaration group should containing globals should contain exactly one declaration"; (* We ignore on purpose functions that cannot fail and consider they *can* * fail: the result of the analysis is not used yet to adjust the translation * so that the functions which syntactically can't fail don't use an error monad. diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 961a64a4..a9ca415e 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -10,6 +10,7 @@ open Values open LlbcAst open Contexts open SynthesizeSymbolic +open Errors module SA = SymbolicAst (** The local logger *) @@ -67,7 +68,7 @@ let normalize_inst_fun_sig (ctx : eval_ctx) (sg : inst_fun_sig) : inst_fun_sig = clauses (we are not considering a function call, so we don't need to normalize because a trait clause was instantiated with a specific trait ref). *) -let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) +let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : fun_sig) (regions_hierarchy : region_var_groups) (kind : item_kind) : eval_ctx * inst_fun_sig = let tr_self = @@ -83,7 +84,7 @@ let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) List.map (fun (v : const_generic_var) -> CgVar v.index) const_generics in (* Annoying that we have to generate this substitution here *) - let r_subst _ = raise (Failure "Unexpected region") in + let r_subst _ = craise meta "Unexpected region" in let ty_subst = Substitute.make_type_subst_from_vars sg.generics.types types in @@ -121,7 +122,7 @@ let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) trait_instance_id = match TraitClauseId.Map.find_opt clause_id tr_map with | Some tr -> tr - | None -> raise (Failure "Local trait clause not found") + | None -> craise meta "Local trait clause not found" in let mk_subst tr_map = let tr_subst = mk_tr_subst tr_map in @@ -149,10 +150,10 @@ let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) in { regions; types; const_generics; trait_refs } in - let inst_sg = instantiate_fun_sig ctx generics tr_self sg regions_hierarchy in + let inst_sg = instantiate_fun_sig meta ctx generics tr_self sg regions_hierarchy in (* Compute the normalization maps *) let ctx = - AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx + AssociatedTypes.ctx_add_norm_trait_types_from_preds meta ctx inst_sg.trait_type_constraints in (* Normalize the signature *) @@ -173,7 +174,7 @@ let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) - the list of symbolic values introduced for the input values - the instantiated function signature *) -let initialize_symbolic_context_for_fun (meta : Meta.meta) (ctx : decls_ctx) (fdef : fun_decl) : +let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : eval_ctx * symbolic_value list * inst_fun_sig = (* The abstractions are not initialized the same way as for function * calls: they contain *loan* projectors, because they "provide" us @@ -195,22 +196,22 @@ let initialize_symbolic_context_for_fun (meta : Meta.meta) (ctx : decls_ctx) (fd List.map (fun (g : region_var_group) -> g.id) regions_hierarchy in let ctx = - initialize_eval_ctx ctx region_groups sg.generics.types + initialize_eval_ctx fdef.meta ctx region_groups sg.generics.types sg.generics.const_generics in (* Instantiate the signature. This updates the context because we compute at the same time the normalization map for the associated types. *) let ctx, inst_sg = - symbolic_instantiate_fun_sig ctx fdef.signature regions_hierarchy fdef.kind + symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy fdef.kind in (* Create fresh symbolic values for the inputs *) let input_svs = - List.map (fun ty -> mk_fresh_symbolic_value ty) inst_sg.inputs + List.map (fun ty -> mk_fresh_symbolic_value fdef.meta ty) inst_sg.inputs in (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) let call_id = fresh_fun_call_id () in - assert (call_id = FunCallId.zero); + cassert (call_id = FunCallId.zero) fdef.meta "The abstractions should be empty (i.e., with no avalues) abstractions"; let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : eval_ctx * typed_avalue list = (* Project over the values - we use *loan* projectors, as explained above *) @@ -232,12 +233,12 @@ let initialize_symbolic_context_for_fun (meta : Meta.meta) (ctx : decls_ctx) (fd Collections.List.split_at (List.tl body.locals) body.arg_count in (* Push the return variable (initialized with ⊥) *) - let ctx = ctx_push_uninitialized_var meta ctx ret_var in + let ctx = ctx_push_uninitialized_var fdef.meta ctx ret_var in (* Push the input variables (initialized with symbolic values) *) let input_values = List.map mk_typed_value_from_symbolic_value input_svs in - let ctx = ctx_push_vars meta ctx (List.combine input_vars input_values) in + let ctx = ctx_push_vars fdef.meta ctx (List.combine input_vars input_values) in (* Push the remaining local variables (initialized with ⊥) *) - let ctx = ctx_push_uninitialized_vars meta ctx local_vars in + let ctx = ctx_push_uninitialized_vars fdef.meta ctx local_vars in (* Return *) (ctx, input_svs, inst_sg) @@ -271,7 +272,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) ^ "\n- inside_loop: " ^ Print.bool_to_string inside_loop ^ "\n- ctx:\n" - ^ Print.Contexts.eval_ctx_to_string ctx)); + ^ Print.Contexts.eval_ctx_to_string fdef.meta ctx)); (* We need to instantiate the function signature - to retrieve * the return type. Note that it is important to re-generate * an instantiation of the signature, so that we use fresh @@ -280,12 +281,12 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies in let _, ret_inst_sg = - symbolic_instantiate_fun_sig ctx fdef.signature regions_hierarchy fdef.kind + symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy fdef.kind in let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) let pop_return_value = is_regular_return in - let cf_pop_frame = pop_frame config pop_return_value in + let cf_pop_frame = pop_frame fdef.meta config pop_return_value in (* We need to find the parents regions/abstractions of the region we * will end - this will allow us to, first, mark the other return @@ -313,7 +314,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : eval_ctx * typed_avalue list = let ctx, avalue = - apply_proj_borrows_on_input_value config ctx abs.regions + apply_proj_borrows_on_input_value fdef.meta config ctx abs.regions abs.ancestors_regions ret_value ret_rty in (ctx, [ avalue ]) @@ -329,7 +330,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) let region_can_end rid = RegionGroupId.Set.mem rid parent_and_current_rgs in - assert (region_can_end back_id); + cassert (region_can_end back_id) fdef.meta "The region should be able to end"; let ctx = create_push_abstractions_from_abs_region_groups (fun rg_id -> SynthRet rg_id) @@ -416,9 +417,9 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) | Loop (loop_id', rg_id', LoopSynthInput) -> (* We only allow to end the loop synth input abs for the region group [rg_id] *) - assert ( + cassert ( if Option.is_some loop_id then loop_id = Some loop_id' - else true); + else true) fdef.meta "Only the loop synth input abs for the region group [rg_id] are allowed to end"; (* Loop abstractions *) let rg_id' = Option.get rg_id' in if rg_id' = back_id && inside_loop then @@ -426,7 +427,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) else abs | Loop (loop_id', _, LoopCall) -> (* We can end all the loop call abstractions *) - assert (loop_id = Some loop_id'); + cassert (loop_id = Some loop_id') fdef.meta "TODO: error message"; { abs with can_end = true } | SynthInput rg_id' -> if rg_id' = back_id && end_fun_synth_input then @@ -446,7 +447,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) let target_abs_ids = List.append parent_input_abs_ids current_abs_id in let cf_end_target_abs cf = List.fold_left - (fun cf id -> end_abstraction config id cf) + (fun cf id -> end_abstraction fdef.meta config id cf) cf target_abs_ids in (* Generate the Return node *) @@ -468,7 +469,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) for the synthesis) - the symbolic AST generated by the symbolic execution *) -let evaluate_function_symbolic (meta : Meta.meta) (synthesize : bool) (ctx : decls_ctx) +let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) (fdef : fun_decl) : symbolic_value list * SA.expression option = (* Debug *) let name_to_string () = @@ -479,7 +480,7 @@ let evaluate_function_symbolic (meta : Meta.meta) (synthesize : bool) (ctx : dec log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); (* Create the evaluation context *) - let ctx, input_svs, inst_sg = initialize_symbolic_context_for_fun meta ctx fdef in + let ctx, input_svs, inst_sg = initialize_symbolic_context_for_fun ctx fdef in let regions_hierarchy = FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies @@ -512,7 +513,7 @@ let evaluate_function_symbolic (meta : Meta.meta) (synthesize : bool) (ctx : dec let fwd_e = (* Pop the frame and retrieve the returned value at the same time*) let pop_return_value = true in - let cf_pop = pop_frame config pop_return_value in + let cf_pop = pop_frame fdef.meta config pop_return_value in (* Generate the Return node *) let cf_return ret_value : m_fun = fun ctx -> Some (SA.Return (ctx, ret_value)) @@ -529,7 +530,7 @@ let evaluate_function_symbolic (meta : Meta.meta) (synthesize : bool) (ctx : dec match res with | Return -> None | LoopReturn loop_id -> Some loop_id - | _ -> raise (Failure "Unreachable") + | _ -> craise fdef.meta "Unreachable" in let is_regular_return = true in let inside_loop = Option.is_some loop_id in @@ -555,14 +556,14 @@ let evaluate_function_symbolic (meta : Meta.meta) (synthesize : bool) (ctx : dec match res with | EndEnterLoop _ -> false | EndContinue _ -> true - | _ -> raise (Failure "Unreachable") + | _ -> craise fdef.meta "Unreachable" in (* Forward translation *) let fwd_e = (* Pop the frame - there is no returned value to pop: in the translation we will simply call the loop function *) let pop_return_value = false in - let cf_pop = pop_frame config pop_return_value in + let cf_pop = pop_frame fdef.meta config pop_return_value in (* Generate the Return node *) let cf_return _ret_value : m_fun = fun _ctx -> Some (SA.ReturnWithLoop (loop_id, inside_loop)) @@ -596,13 +597,13 @@ let evaluate_function_symbolic (meta : Meta.meta) (synthesize : bool) (ctx : dec * the executions can lead to a panic *) if synthesize then Some SA.Panic else None | Unit | Break _ | Continue _ -> - raise - (Failure ("evaluate_function_symbolic failed on: " ^ name_to_string ())) + craise + fdef.meta ("evaluate_function_symbolic failed on: " ^ name_to_string ()) in (* Evaluate the function *) let symbolic = - eval_function_body config (Option.get fdef.body).body cf_finish ctx + eval_function_body fdef.meta config (Option.get fdef.body).body cf_finish ctx in (* Return *) @@ -612,7 +613,7 @@ module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty environment. *) - let test_unit_function (meta : Meta.meta) (crate : crate) (decls_ctx : decls_ctx) + let test_unit_function (crate : crate) (decls_ctx : decls_ctx) (fid : FunDeclId.id) : unit = (* Retrieve the function declaration *) let fdef = FunDeclId.Map.find fid crate.fun_decls in @@ -627,14 +628,14 @@ module Test = struct fdef.name)); (* Sanity check - *) - assert (fdef.signature.generics = empty_generic_params); - assert (body.arg_count = 0); + cassert (fdef.signature.generics = empty_generic_params) fdef.meta "TODO: Error message"; + cassert (body.arg_count = 0) fdef.meta "TODO: Error message"; (* Create the evaluation context *) - let ctx = initialize_eval_ctx decls_ctx [] [] [] in + let ctx = initialize_eval_ctx fdef.meta decls_ctx [] [] [] in (* Insert the (uninitialized) local variables *) - let ctx = ctx_push_uninitialized_vars meta ctx body.locals in + let ctx = ctx_push_uninitialized_vars fdef.meta ctx body.locals in (* Create the continuation to check the function's result *) let config = mk_config ConcreteMode in @@ -643,18 +644,18 @@ module Test = struct | Return -> (* Ok: drop the local variables and finish *) let pop_return_value = true in - pop_frame config pop_return_value (fun _ _ -> None) ctx + pop_frame fdef.meta config pop_return_value (fun _ _ -> None) ctx | _ -> - raise - (Failure + craise + fdef.meta ("Unit test failed (concrete execution) on: " ^ Print.Types.name_to_string (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) - fdef.name)) + fdef.name) in (* Evaluate the function *) - let _ = eval_function_body config body.body cf_check ctx in + let _ = eval_function_body body.meta config body.body cf_check ctx in () (** Small helper: return true if the function is a *transparent* unit function @@ -665,7 +666,7 @@ module Test = struct && def.signature.inputs = [] (** Test all the unit functions in a list of function definitions *) - let test_unit_functions (meta : Meta.meta) (crate : crate) : unit = + let test_unit_functions (crate : crate) : unit = let unit_funs = FunDeclId.Map.filter (fun _ -> fun_decl_is_transparent_unit) @@ -673,7 +674,7 @@ module Test = struct in let decls_ctx = compute_contexts crate in let test_unit_fun _ (def : fun_decl) : unit = - test_unit_function meta crate decls_ctx def.def_id + test_unit_function crate decls_ctx def.def_id in FunDeclId.Map.iter test_unit_fun unit_funs end diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index e37a67b7..be31d865 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -216,7 +216,7 @@ let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id opt set_replaced_bc (fst outer) (Abstract bc); (* Update the value - note that we are necessarily in the second * of the two cases described above *) - let asb = remove_borrow_from_asb l asb in + let asb = remove_borrow_from_asb meta l asb in ABorrow (AProjSharedBorrow asb)) else (* Nothing special to do *) super#visit_ABorrow outer bc @@ -254,8 +254,8 @@ let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv log#ldebug (lazy ("give_back_value:\n- bid: " ^ BorrowId.to_string bid ^ "\n- value: " - ^ typed_value_to_string ctx nv - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + ^ typed_value_to_string meta ctx nv + ^ "\n- context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -267,7 +267,7 @@ let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv (* We sometimes need to reborrow values while giving a value back due: prepare that *) let allow_reborrows = true in let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows + prepare_reborrows meta config allow_reborrows in (* The visitor to give back the values *) let obj = @@ -335,7 +335,7 @@ let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv (* Remember the given back value as a meta-value * TODO: it is a bit annoying to have to deconstruct * the value... Think about a more elegant way. *) - let given_back_meta = as_symbolic nv.value in + let given_back_meta = as_symbolic meta nv.value in (* The loan projector *) let given_back = mk_aproj_loans_value_from_symbolic_value abs.regions sv @@ -382,7 +382,7 @@ let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv let given_back_meta = nv in (* Apply the projection *) let given_back = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions nv borrowed_value_aty in (* Continue giving back in the child value *) @@ -409,7 +409,7 @@ let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv * we don't register the fact that we inserted the value somewhere * (i.e., we don't call {!set_replaced}) *) let given_back = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions nv borrowed_value_aty in (* Continue giving back in the child value *) @@ -720,8 +720,8 @@ let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (new_bid : B be expanded (because expanding this symbolic value would require expanding a reference whose region has already ended). *) -let convert_avalue_to_given_back_value (av : typed_avalue) : symbolic_value = - mk_fresh_symbolic_value av.ty +let convert_avalue_to_given_back_value (meta : Meta.meta) (av : typed_avalue) : symbolic_value = + mk_fresh_symbolic_value meta av.ty (** Auxiliary function: see {!end_borrow_aux}. @@ -746,11 +746,11 @@ let give_back (meta : Meta.meta) (config : config) (l : BorrowId.id) (bc : g_bor (lazy (let bc = match bc with - | Concrete bc -> borrow_content_to_string ctx bc - | Abstract bc -> aborrow_content_to_string ctx bc + | Concrete bc -> borrow_content_to_string meta ctx bc + | Abstract bc -> aborrow_content_to_string meta ctx bc in "give_back:\n- bid: " ^ BorrowId.to_string l ^ "\n- content: " ^ bc - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + ^ "\n- context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); (* This is used for sanity checks *) let sanity_ek = { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } @@ -781,7 +781,7 @@ let give_back (meta : Meta.meta) (config : config) (l : BorrowId.id) (bc : g_bor Rem.: we shouldn't do this here. We should do this in a function which takes care of ending *sub*-abstractions. *) - let sv = convert_avalue_to_given_back_value av in + let sv = convert_avalue_to_given_back_value meta av in (* Update the context *) give_back_avalue_to_same_abstraction meta config l av (mk_typed_value_from_symbolic_value sv) @@ -814,8 +814,8 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI (lazy (fun_name ^ ": " ^ BorrowId.to_string l ^ ": borrow didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx0 ^ "\n\n- new context:\n" + ^ eval_ctx_to_string meta ctx)); craise meta "Borrow not eliminated" in match lookup_loan_opt meta ek_all l ctx with @@ -825,8 +825,8 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI (lazy (fun_name ^ ": " ^ BorrowId.to_string l ^ ": loan didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx0 ^ "\n\n- new context:\n" + ^ eval_ctx_to_string meta ctx)); craise meta "Loan not eliminated" in unit_to_cm_fun check_disappeared @@ -858,12 +858,12 @@ let rec end_borrow_aux (meta : Meta.meta) (config : config) (chain : borrow_or_a (* Check that we don't loop *) let chain0 = chain in let chain = - add_borrow_or_abs_id_to_chain "end_borrow_aux: " (BorrowId l) chain + add_borrow_or_abs_id_to_chain meta "end_borrow_aux: " (BorrowId l) chain in log#ldebug (lazy ("end borrow: " ^ BorrowId.to_string l ^ ":\n- original context:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx)); (* Utility function for the sanity checks: check that the borrow disappeared * from the context *) @@ -958,7 +958,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ fun cf ctx -> (* Check that we don't loop *) let chain = - add_borrow_or_abs_id_to_chain "end_abstraction_aux: " (AbsId abs_id) chain + add_borrow_or_abs_id_to_chain meta "end_abstraction_aux: " (AbsId abs_id) chain in (* Remember the original context for printing purposes *) let ctx0 = ctx in @@ -966,7 +966,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0)); + ^ "\n- original context:\n" ^ eval_ctx_to_string meta ctx0)); (* Lookup the abstraction - note that if we end a list of abstractions, ending one abstraction may lead to the current abstraction having @@ -999,7 +999,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id ^ "\n- context after parent abstractions ended:\n" - ^ eval_ctx_to_string ctx))) + ^ eval_ctx_to_string meta ctx))) in (* End the loans inside the abstraction *) @@ -1010,7 +1010,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ctx))) + ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string meta ctx))) in (* End the abstraction itself by redistributing the borrows it contains *) @@ -1039,8 +1039,8 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx))) + ^ "\n- original context:\n" ^ eval_ctx_to_string meta ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string meta ctx))) in (* Sanity check: ending an abstraction must preserve the invariants *) @@ -1173,12 +1173,12 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow log#ldebug (lazy ("end_abstraction_borrows: found aborrow content: " - ^ aborrow_content_to_string ctx bc)); + ^ aborrow_content_to_string meta ctx bc)); let ctx = match bc with | AMutBorrow (bid, av) -> (* First, convert the avalue to a (fresh symbolic) value *) - let sv = convert_avalue_to_given_back_value av in + let sv = convert_avalue_to_given_back_value meta av in (* Replace the mut borrow to register the fact that we ended * it and store with it the freshly generated given back value *) let ended_borrow = ABorrow (AEndedMutBorrow (sv, av)) in @@ -1228,7 +1228,7 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow ("end_abstraction_borrows: found aproj borrows: " ^ aproj_to_string ctx (AProjBorrows (sv, proj_ty)))); (* Generate a fresh symbolic value *) - let nsv = mk_fresh_symbolic_value proj_ty in + let nsv = mk_fresh_symbolic_value meta proj_ty in (* Replace the proj_borrows - there should be exactly one *) let ended_borrow = AEndedProjBorrows nsv in let ctx = update_aproj_borrows meta abs.abs_id sv ended_borrow ctx in @@ -1243,7 +1243,7 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow log#ldebug (lazy ("end_abstraction_borrows: found borrow content: " - ^ borrow_content_to_string ctx bc)); + ^ borrow_content_to_string meta ctx bc)); let ctx = match bc with | VSharedBorrow bid -> ( @@ -1432,16 +1432,16 @@ let end_abstraction meta config = end_abstraction_aux meta config [] let end_abstractions meta config = end_abstractions_aux meta config [] let end_borrow_no_synth meta config id ctx = - get_cf_ctx_no_synth (end_borrow meta config id) ctx + get_cf_ctx_no_synth meta (end_borrow meta config id) ctx let end_borrows_no_synth meta config ids ctx = - get_cf_ctx_no_synth (end_borrows meta config ids) ctx + get_cf_ctx_no_synth meta (end_borrows meta config ids) ctx let end_abstraction_no_synth meta config id ctx = - get_cf_ctx_no_synth (end_abstraction meta config id) ctx + get_cf_ctx_no_synth meta (end_abstraction meta config id) ctx let end_abstractions_no_synth meta config ids ctx = - get_cf_ctx_no_synth (end_abstractions meta config ids) ctx + get_cf_ctx_no_synth meta (end_abstractions meta config ids) ctx (** Helper function: see {!activate_reserved_mut_borrow}. @@ -1466,7 +1466,7 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) log#ldebug (lazy ("promote_shared_loan_to_mut_loan:\n- loan: " ^ BorrowId.to_string l - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + ^ "\n- context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); (* Lookup the shared loan - note that we can't promote a shared loan * in a shared value, but we can do it in a mutably borrowed value. * This is important because we can do: [let y = &two-phase ( *x );] @@ -1563,7 +1563,7 @@ let rec promote_reserved_mut_borrow (meta : Meta.meta) (config : config) (l : Bo log#ldebug (lazy ("activate_reserved_mut_borrow: resulting value:\n" - ^ typed_value_to_string ctx sv)); + ^ typed_value_to_string meta ctx sv)); cassert (not (loans_in_value sv)) meta "TODO: error message"; cassert (not (bottom_in_value ctx.ended_regions sv)) meta "TODO: error message"; cassert (not (reserved_in_value sv)) meta "TODO: error message"; @@ -1627,7 +1627,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) if destructure_shared_values then list_values sv else ([], sv) in (* Push a value *) - let ignored = mk_aignored child_av.ty in + let ignored = mk_aignored meta child_av.ty in let value = ALoan (ASharedLoan (bids, sv, ignored)) in push { value; ty }; (* Explore the child *) @@ -1643,7 +1643,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (* Explore the child *) list_avalues false push_fail child_av; (* Explore the whole loan *) - let ignored = mk_aignored child_av.ty in + let ignored = mk_aignored meta child_av.ty in let value = ALoan (AMutLoan (bid, ignored)) in push { value; ty } | AIgnoredMutLoan (opt_bid, child_av) -> @@ -1671,7 +1671,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (* Explore the child *) list_avalues false push_fail child_av; (* Explore the borrow *) - let ignored = mk_aignored child_av.ty in + let ignored = mk_aignored meta child_av.ty in let value = ABorrow (AMutBorrow (bid, ignored)) in push { value; ty } | ASharedBorrow _ -> @@ -1742,7 +1742,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) in let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) - let value = ALoan (ASharedLoan (bids, sv, mk_aignored ty)) in + let value = ALoan (ASharedLoan (bids, sv, mk_aignored meta ty)) in { value; ty } in let avl = List.append [ av ] avl in @@ -1808,7 +1808,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ log#ldebug (lazy ("convert_value_to_abstractions: to_avalues:\n- value: " - ^ typed_value_to_string ctx v)); + ^ typed_value_to_string meta ctx v)); let ty = v.ty in match v.value with @@ -1868,7 +1868,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ cassert (not (value_has_borrows ctx bv.value)) meta "Nested borrows are not supported yet"; (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) let ty = TRef (RFVar r_id, ref_ty, kind) in - let ignored = mk_aignored ref_ty in + let ignored = mk_aignored meta ref_ty in let av = ABorrow (AMutBorrow (bid, ignored)) in let av = { value = av; ty } in (* Continue exploring, looking for loans (and forbidding borrows, @@ -1889,7 +1889,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ (* For avalues, a loan has the borrow type *) cassert (ty_no_regions ty) meta "TODO: error message"; let ty = mk_ref_ty (RFVar r_id) ty RShared in - let ignored = mk_aignored ty in + let ignored = mk_aignored meta ty in (* Rem.: the shared value might contain loans *) let avl, sv = to_avalues false true true r_id sv in let av = ALoan (ASharedLoan (bids, sv, ignored)) in @@ -1907,7 +1907,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ (* For avalues, a loan has the borrow type *) cassert (ty_no_regions ty) meta "TODO: error message"; let ty = mk_ref_ty (RFVar r_id) ty RMut in - let ignored = mk_aignored ty in + let ignored = mk_aignored meta ty in let av = ALoan (AMutLoan (bid, ignored)) in let av = { value = av; ty } in ([ av ], v)) @@ -2140,8 +2140,8 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end (abs1 : abs) : abs = log#ldebug (lazy - ("merge_into_abstraction_aux:\n- abs0:\n" ^ abs_to_string ctx abs0 - ^ "\n\n- abs1:\n" ^ abs_to_string ctx abs1)); + ("merge_into_abstraction_aux:\n- abs0:\n" ^ abs_to_string meta ctx abs0 + ^ "\n\n- abs1:\n" ^ abs_to_string meta ctx abs1)); (* Check that the abstractions are destructured *) if !Config.sanity_checks then ( @@ -2201,7 +2201,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end log#ldebug (lazy ("merge_into_abstraction_aux: push_avalue: " - ^ typed_avalue_to_string ctx av)); + ^ typed_avalue_to_string meta ctx av)); avalues := av :: !avalues in let push_opt_avalue av = diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index e47ba82d..95a27245 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -8,37 +8,37 @@ open Cps applies this change to an environment [ctx] by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -val reborrow_shared : BorrowId.id -> BorrowId.id -> eval_ctx -> eval_ctx +val reborrow_shared : Meta.meta -> BorrowId.id -> BorrowId.id -> eval_ctx -> eval_ctx (** End a borrow identified by its id, while preserving the invariants. If the borrow is inside another borrow/an abstraction or contains loans, [end_borrow] will end those borrows/abstractions/loans first. *) -val end_borrow : config -> BorrowId.id -> cm_fun +val end_borrow : Meta.meta -> config -> BorrowId.id -> cm_fun (** End a set of borrows identified by their ids, while preserving the invariants. *) -val end_borrows : config -> BorrowId.Set.t -> cm_fun +val end_borrows : Meta.meta -> config -> BorrowId.Set.t -> cm_fun (** End an abstraction while preserving the invariants. *) -val end_abstraction : config -> AbstractionId.id -> cm_fun +val end_abstraction : Meta.meta -> config -> AbstractionId.id -> cm_fun (** End a set of abstractions while preserving the invariants. *) -val end_abstractions : config -> AbstractionId.Set.t -> cm_fun +val end_abstractions : Meta.meta -> config -> AbstractionId.Set.t -> cm_fun (** End a borrow and return the resulting environment, ignoring synthesis *) -val end_borrow_no_synth : config -> BorrowId.id -> eval_ctx -> eval_ctx +val end_borrow_no_synth : Meta.meta -> config -> BorrowId.id -> eval_ctx -> eval_ctx (** End a set of borrows and return the resulting environment, ignoring synthesis *) -val end_borrows_no_synth : config -> BorrowId.Set.t -> eval_ctx -> eval_ctx +val end_borrows_no_synth : Meta.meta -> config -> BorrowId.Set.t -> eval_ctx -> eval_ctx (** End an abstraction and return the resulting environment, ignoring synthesis *) val end_abstraction_no_synth : - config -> AbstractionId.id -> eval_ctx -> eval_ctx + Meta.meta -> config -> AbstractionId.id -> eval_ctx -> eval_ctx (** End a set of abstractions and return the resulting environment, ignoring synthesis *) val end_abstractions_no_synth : - config -> AbstractionId.Set.t -> eval_ctx -> eval_ctx + Meta.meta -> config -> AbstractionId.Set.t -> eval_ctx -> eval_ctx (** Promote a reserved mut borrow to a mut borrow, while preserving the invariants. @@ -49,7 +49,7 @@ val end_abstractions_no_synth : the corresponding shared loan with a mutable loan (after having ended the other shared borrows which point to this loan). *) -val promote_reserved_mut_borrow : config -> BorrowId.id -> cm_fun +val promote_reserved_mut_borrow : Meta.meta -> config -> BorrowId.id -> cm_fun (** Transform an abstraction to an abstraction where the values are not structured. @@ -91,7 +91,7 @@ val promote_reserved_mut_borrow : config -> BorrowId.id -> cm_fun - [ctx] - [abs] *) -val destructure_abs : abs_kind -> bool -> bool -> eval_ctx -> abs -> abs +val destructure_abs : Meta.meta -> abs_kind -> bool -> bool -> eval_ctx -> abs -> abs (** Return [true] if the values in an abstraction are destructured. @@ -99,7 +99,7 @@ val destructure_abs : abs_kind -> bool -> bool -> eval_ctx -> abs -> abs The input boolean is [destructure_shared_value]. See {!destructure_abs}. *) -val abs_is_destructured : bool -> eval_ctx -> abs -> bool +val abs_is_destructured : Meta.meta -> bool -> eval_ctx -> abs -> bool (** Turn a value into a abstractions. @@ -125,7 +125,7 @@ val abs_is_destructured : bool -> eval_ctx -> abs -> bool - [v] *) val convert_value_to_abstractions : - abs_kind -> bool -> bool -> eval_ctx -> typed_value -> abs list + Meta.meta -> abs_kind -> bool -> bool -> eval_ctx -> typed_value -> abs list (** See {!merge_into_abstraction}. @@ -232,6 +232,7 @@ type merge_duplicates_funcs = { results from the merge. *) val merge_into_abstraction : + Meta.meta -> abs_kind -> bool -> merge_duplicates_funcs option -> diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 5b84e2c0..6691fdcd 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -72,13 +72,13 @@ let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = String.concat " -> " ids (** Add a borrow or abs id to a chain of ids, while checking that we don't loop *) -let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) +let add_borrow_or_abs_id_to_chain (meta : Meta.meta) (msg : string) (id : borrow_or_abs_id) (ids : borrow_or_abs_ids) : borrow_or_abs_ids = if List.mem id ids then - raise - (Failure + craise + meta (msg ^ "detected a loop in the chain of ids: " - ^ borrow_or_abs_ids_chain_to_string (id :: ids))) + ^ borrow_or_abs_ids_chain_to_string (id :: ids)) else id :: ids (** Helper function. @@ -100,14 +100,14 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool = let compare = compare_rtys meta default combine compare_regions in (* Sanity check - TODO: don't do this at every recursive call *) - cassert (ty_is_rty ty1 && ty_is_rty ty2) meta "ty1 or ty2 are not rty TODO"; + cassert (ty_is_rty ty1 && ty_is_rty ty2) meta "ty1 or ty2 are not rty TODO: Error message"; (* Normalize the associated types *) match (ty1, ty2) with | TLiteral lit1, TLiteral lit2 -> - cassert (lit1 = lit2) meta "Tlitrals are not equal TODO"; + cassert (lit1 = lit2) meta "Tlitrals are not equal TODO: Error message"; default | TAdt (id1, generics1), TAdt (id2, generics2) -> - cassert (id1 = id2) meta "ids are not equal TODO"; + cassert (id1 = id2) meta "ids are not equal TODO: Error message"; (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) cassert (generics1.const_generics = generics2.const_generics) meta "const generics are not the same"; @@ -144,7 +144,7 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool combine params_b tys_b | TRef (r1, ty1, kind1), TRef (r2, ty2, kind2) -> (* Sanity check *) - cassert (kind1 = kind2) meta "kind1 and kind2 are not equal TODO"; + cassert (kind1 = kind2) meta "kind1 and kind2 are not equal TODO: Error message"; (* Explanation for the case where we check if projections intersect: * the projections intersect if the borrows intersect or their contents * intersect. *) @@ -152,7 +152,7 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool let tys_b = compare ty1 ty2 in combine regions_b tys_b | TVar id1, TVar id2 -> - cassert (id1 = id2) meta "Ids are not the same TODO"; + cassert (id1 = id2) meta "Ids are not the same TODO: Error message"; default | TTraitType _, TTraitType _ -> (* The types should have been normalized. If after normalization we @@ -301,7 +301,7 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) The loan is referred to by a borrow id. Raises an exception if no loan was found. *) -let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : +let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : abs_or_var_id * g_loan_content = match lookup_loan_opt meta ek l ctx with | None -> craise meta "Unreachable" @@ -936,7 +936,7 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId. (subst : abs -> (msymbolic_value * aproj) list -> aproj) (ctx : eval_ctx) : eval_ctx = (* *) - cassert (ty_is_rty proj_ty) meta "proj_ty is not rty TODO"; + cassert (ty_is_rty proj_ty) meta "proj_ty is not rty TODO: Error message"; (* Small helpers for sanity checks *) let updated = ref false in let update abs local_given_back : aproj = @@ -1158,7 +1158,7 @@ let no_aproj_over_symbolic_in_context (meta : Meta.meta) (sv : symbolic_value) **Remark:** we don't take the *ignored* mut/shared loans into account. *) -let get_first_non_ignored_aloan_in_abstraction (meta : Meta.meta) (abs : abs) : +let get_first_non_ignored_aloan_in_abstraction (meta : Meta.meta) (abs : abs) : borrow_ids_or_symbolic_value option = (* Explore to find a loan *) let obj = diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 0a5a289e..9448f3e8 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -56,7 +56,7 @@ let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : conf let check_symbolic_no_ended = false in (* Prepare reborrows registration *) let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows + prepare_reborrows meta config allow_reborrows in (* Visitor to apply the expansion *) let obj = @@ -66,7 +66,7 @@ let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : conf (** When visiting an abstraction, we remember the regions it owns to be able to properly reduce projectors when expanding symbolic values *) method! visit_abs current_abs abs = - cassert (Option.is_none current_abs) meta "T"; + cassert (Option.is_none current_abs) meta "TODO: error message"; let current_abs = Some abs in super#visit_abs current_abs abs @@ -78,7 +78,7 @@ let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : conf method! visit_aproj current_abs aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - cassert (not (same_symbolic_id sv original_sv)) meta "T" + cassert (not (same_symbolic_id sv original_sv)) meta "TODO: error message" | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj current_abs aproj @@ -98,10 +98,10 @@ let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : conf (* Check if this is the symbolic value we are looking for *) if same_symbolic_id sv original_sv then ( (* There mustn't be any given back values *) - cassert (given_back = []) meta "T"; + cassert (given_back = []) meta "TODO: error message"; (* Apply the projector *) let projected_value = - apply_proj_loans_on_symbolic_expansion proj_regions + apply_proj_loans_on_symbolic_expansion meta proj_regions ancestors_regions expansion original_sv.sv_ty in (* Replace *) @@ -118,12 +118,12 @@ let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : conf (* WARNING: we mustn't get there if the expansion is for a shared * reference. *) let expansion = - symbolic_expansion_non_shared_borrow_to_value original_sv + symbolic_expansion_non_shared_borrow_to_value meta original_sv expansion in (* Apply the projector *) let projected_value = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow proj_regions ancestors_regions expansion proj_ty in (* Replace *) @@ -168,7 +168,7 @@ let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) (original_s (* Count *) let replaced = ref false in let replace () = - if at_most_once then cassert (not !replaced) meta "T"; + if at_most_once then cassert (not !replaced) meta "TODO: error message"; replaced := true; nv in @@ -191,7 +191,7 @@ let apply_symbolic_expansion_non_borrow (meta : Meta.meta) (config : config) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = (* Apply the expansion to non-abstraction values *) - let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in + let nv = symbolic_expansion_non_borrow_to_value meta original_sv expansion in let at_most_once = false in let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in (* Apply the expansion to abstraction values *) @@ -215,7 +215,7 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (expand_e (* Lookup the definition and check if it is an enumeration with several * variants *) let def = ctx_lookup_type_decl ctx def_id in - cassert (List.length generics.regions = List.length def.generics.regions) meta "T"; + cassert (List.length generics.regions = List.length def.generics.regions) meta "TODO: error message"; (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = AssociatedTypes.type_decl_get_inst_norm_variants_fields_rtypes ctx def @@ -228,7 +228,7 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (expand_e let initialize ((variant_id, field_types) : VariantId.id option * rty list) : symbolic_expansion = let field_values = - List.map (fun (ty : rty) -> mk_fresh_symbolic_value ty) field_types + List.map (fun (ty : rty) -> mk_fresh_symbolic_value meta ty) field_types in let see = SeAdt (variant_id, field_values) in see @@ -236,19 +236,19 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (expand_e (* Initialize all the expanded values of all the variants *) List.map initialize variants_fields_types -let compute_expanded_symbolic_tuple_value (field_types : rty list) : +let compute_expanded_symbolic_tuple_value (meta : Meta.meta) (field_types : rty list) : symbolic_expansion = (* Generate the field values *) let field_values = - List.map (fun sv_ty -> mk_fresh_symbolic_value sv_ty) field_types + List.map (fun sv_ty -> mk_fresh_symbolic_value meta sv_ty) field_types in let variant_id = None in let see = SeAdt (variant_id, field_values) in see -let compute_expanded_symbolic_box_value (boxed_ty : rty) : symbolic_expansion = +let compute_expanded_symbolic_box_value (meta : Meta.meta) (boxed_ty : rty) : symbolic_expansion = (* Introduce a fresh symbolic value *) - let boxed_value = mk_fresh_symbolic_value boxed_ty in + let boxed_value = mk_fresh_symbolic_value meta boxed_ty in let see = SeAdt (None, [ boxed_value ]) in see @@ -268,9 +268,9 @@ let compute_expanded_symbolic_adt_value (meta : Meta.meta) (expand_enumerations | TAdtId def_id, _, _ -> compute_expanded_symbolic_non_assumed_adt_value meta expand_enumerations def_id generics ctx - | TTuple, [], _ -> [ compute_expanded_symbolic_tuple_value generics.types ] + | TTuple, [], _ -> [ compute_expanded_symbolic_tuple_value meta generics.types ] | TAssumed TBox, [], [ boxed_ty ] -> - [ compute_expanded_symbolic_box_value boxed_ty ] + [ compute_expanded_symbolic_box_value meta boxed_ty ] | _ -> craise meta "compute_expanded_symbolic_adt_value: unexpected combination" @@ -312,7 +312,7 @@ let expand_symbolic_value_shared_borrow (meta : Meta.meta) (config : config) else None in (* The fresh symbolic value for the shared value *) - let shared_sv = mk_fresh_symbolic_value ref_ty in + let shared_sv = mk_fresh_symbolic_value meta ref_ty in (* Visitor to replace the projectors on borrows *) let obj = object (self) @@ -325,7 +325,7 @@ let expand_symbolic_value_shared_borrow (meta : Meta.meta) (config : config) else super#visit_VSymbolic env sv method! visit_EAbs proj_regions abs = - cassert (Option.is_none proj_regions) meta "T"; + cassert (Option.is_none proj_regions) meta "TODO: error message"; let proj_regions = Some abs.regions in super#visit_EAbs proj_regions abs @@ -350,7 +350,7 @@ let expand_symbolic_value_shared_borrow (meta : Meta.meta) (config : config) method! visit_aproj proj_regions aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - cassert (not (same_symbolic_id sv original_sv)) meta "T" + cassert (not (same_symbolic_id sv original_sv)) meta "TODO: error message" | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj proj_regions aproj @@ -376,7 +376,7 @@ let expand_symbolic_value_shared_borrow (meta : Meta.meta) (config : config) let ctx = obj#visit_eval_ctx None ctx in (* Finally, replace the projectors on loans *) let bids = !borrows in - cassert (not (BorrowId.Set.is_empty bids)) meta "T"; + cassert (not (BorrowId.Set.is_empty bids)) meta "TODO: error message"; let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = @@ -394,20 +394,20 @@ let expand_symbolic_value_borrow (meta : Meta.meta) (config : config) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) (region : region) (ref_ty : rty) (rkind : ref_kind) : cm_fun = fun cf ctx -> - cassert (region <> RErased) meta "T"; + cassert (region <> RErased) meta "TODO: error message"; (* Check that we are allowed to expand the reference *) - cassert (not (region_in_set region ctx.ended_regions)) meta "T"; + cassert (not (region_in_set region ctx.ended_regions)) meta "TODO: error message"; (* Match on the reference kind *) match rkind with | RMut -> (* Simple case: simply create a fresh symbolic value and a fresh * borrow id *) - let sv = mk_fresh_symbolic_value ref_ty in + let sv = mk_fresh_symbolic_value meta ref_ty in let bid = fresh_borrow_id () in let see = SeMutRef (bid, sv) in (* Expand the symbolic values - we simply perform a substitution (and * check that we perform exactly one substitution) *) - let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in + let nv = symbolic_expansion_non_shared_borrow_to_value meta original_sv see in let at_most_once = true in let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in (* Expand the symbolic avalues *) @@ -446,7 +446,7 @@ let apply_branching_symbolic_expansions_non_borrow (meta : Meta.meta) (config : (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = fun ctx -> - cassert (see_cf_l <> []) meta "T"; + cassert (see_cf_l <> []) meta "TODO: error message"; (* Apply the symbolic expansion in the context and call the continuation *) let resl = List.map @@ -464,8 +464,8 @@ let apply_branching_symbolic_expansions_non_borrow (meta : Meta.meta) (config : (lazy ("apply_branching_symbolic_expansions_non_borrow: " ^ symbolic_value_to_string ctx0 sv - ^ "\n\n- original context:\n" ^ eval_ctx_to_string ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + ^ "\n\n- original context:\n" ^ eval_ctx_to_string meta ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); (* Continuation *) cf_br cf_after_join ctx) see_cf_l @@ -476,7 +476,7 @@ let apply_branching_symbolic_expansions_non_borrow (meta : Meta.meta) (config : match resl with | Some _ :: _ -> Some (List.map Option.get resl) | None :: _ -> - List.iter (fun res -> cassert (res = None) meta "T") resl; + List.iter (fun res -> cassert (res = None) meta "TODO: error message") resl; None | _ -> craise meta "Unreachable" in @@ -492,7 +492,7 @@ let expand_symbolic_bool (meta : Meta.meta) (config : config) (sv : symbolic_val let original_sv = sv in let original_sv_place = sv_place in let rty = original_sv.sv_ty in - cassert (rty = TLiteral TBool) meta "T"; + cassert (rty = TLiteral TBool) meta "TODO: error message"; (* Expand the symbolic value to true or false and continue execution *) let see_true = SeLiteral (VBool true) in let see_false = SeLiteral (VBool false) in @@ -554,10 +554,10 @@ let expand_symbolic_value_no_branching (meta : Meta.meta) (config : config) (sv (lazy ("expand_symbolic_value_no_branching: " ^ symbolic_value_to_string ctx0 sv - ^ "\n\n- original context:\n" ^ eval_ctx_to_string ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + ^ "\n\n- original context:\n" ^ eval_ctx_to_string meta ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); (* Sanity check: the symbolic value has disappeared *) - cassert (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta "T") + cassert (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta "TODO: error message") in (* Continue *) cc cf ctx @@ -594,7 +594,7 @@ let expand_symbolic_int (meta : Meta.meta) (config : config) (sv : symbolic_valu (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) - cassert (sv.sv_ty = TLiteral (TInteger int_type)) meta "T"; + cassert (sv.sv_ty = TLiteral (TInteger int_type)) meta "TODO: error message"; (* For all the branches of the switch, we expand the symbolic value * to the value given by the branch and execute the branch statement. * For the otherwise branch, we leave the symbolic value as it is diff --git a/compiler/InterpreterExpansion.mli b/compiler/InterpreterExpansion.mli index b545f979..3540d04c 100644 --- a/compiler/InterpreterExpansion.mli +++ b/compiler/InterpreterExpansion.mli @@ -12,11 +12,11 @@ type proj_kind = LoanProj | BorrowProj This function does *not* update the synthesis. *) val apply_symbolic_expansion_non_borrow : - config -> symbolic_value -> symbolic_expansion -> eval_ctx -> eval_ctx + Meta.meta -> config -> symbolic_value -> symbolic_expansion -> eval_ctx -> eval_ctx (** Expand a symhbolic value, without branching *) val expand_symbolic_value_no_branching : - config -> symbolic_value -> SA.mplace option -> cm_fun + Meta.meta -> config -> symbolic_value -> SA.mplace option -> cm_fun (** Expand a symbolic enumeration (leads to branching if the enumeration has more than one variant). @@ -32,7 +32,7 @@ val expand_symbolic_value_no_branching : then call it). *) val expand_symbolic_adt : - config -> symbolic_value -> SA.mplace option -> st_cm_fun -> st_m_fun -> m_fun + Meta.meta -> config -> symbolic_value -> SA.mplace option -> st_cm_fun -> st_m_fun -> m_fun (** Expand a symbolic boolean. @@ -41,6 +41,7 @@ val expand_symbolic_adt : parameter (here, there are exactly two branches). *) val expand_symbolic_bool : + Meta.meta -> config -> symbolic_value -> SA.mplace option -> @@ -69,6 +70,7 @@ val expand_symbolic_bool : switch. The continuation is thus for the execution *after* the switch. *) val expand_symbolic_int : + Meta.meta -> config -> symbolic_value -> SA.mplace option -> @@ -81,4 +83,4 @@ val expand_symbolic_int : (** If this mode is activated through the [config], greedily expand the symbolic values which need to be expanded. See {!type:Contexts.config} for more information. *) -val greedy_expand_symbolic_values : config -> cm_fun +val greedy_expand_symbolic_values : Meta.meta -> config -> cm_fun diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 51be904f..f82c7130 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -11,6 +11,7 @@ open Cps open InterpreterUtils open InterpreterExpansion open InterpreterPaths +open Errors (** The local logger *) let log = Logging.expressions_log @@ -29,14 +30,14 @@ let expand_primitively_copyable_at_place (meta : Meta.meta) (config : config) (* Small helper *) let rec expand : cm_fun = fun cf ctx -> - let v = read_place access p ctx in + let v = read_place meta access p ctx in match find_first_primitively_copyable_sv_with_borrows ctx.type_ctx.type_infos v with | None -> cf ctx | Some sv -> let cc = - expand_symbolic_value_no_branching config sv (Some (mk_mplace meta p ctx)) + expand_symbolic_value_no_branching meta config sv (Some (mk_mplace meta p ctx)) in comp cc expand cf ctx in @@ -48,14 +49,14 @@ let expand_primitively_copyable_at_place (meta : Meta.meta) (config : config) We also check that the value *doesn't contain bottoms or reserved borrows*. *) -let read_place (access : access_kind) (p : place) (cf : typed_value -> m_fun) : +let read_place (meta : Meta.meta) (access : access_kind) (p : place) (cf : typed_value -> m_fun) : m_fun = fun ctx -> - let v = read_place access p ctx in + let v = read_place meta access p ctx in (* Check that there are no bottoms in the value *) - assert (not (bottom_in_value ctx.ended_regions v)); + cassert (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value"; (* Check that there are no reserved borrows in the value *) - assert (not (reserved_in_value v)); + cassert (not (reserved_in_value v)) meta "There should be no reserved borrows in the value"; (* Call the continuation *) cf v ctx @@ -64,9 +65,9 @@ let access_rplace_reorganize_and_read (meta : Meta.meta) (config : config) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Make sure we can evaluate the path *) - let cc = update_ctx_along_read_place config access p in + let cc = update_ctx_along_read_place meta config access p in (* End the proper loans at the place itself *) - let cc = comp cc (end_loans_at_place config access p) in + let cc = comp cc (end_loans_at_place meta config access p) in (* Expand the copyable values which contain borrows (which are necessarily shared * borrows) *) let cc = @@ -75,7 +76,7 @@ let access_rplace_reorganize_and_read (meta : Meta.meta) (config : config) else cc in (* Read the place - note that this checks that the value doesn't contain bottoms *) - let read_place = read_place access p in + let read_place = read_place meta access p in (* Compose *) comp cc read_place cf ctx @@ -87,7 +88,7 @@ let access_rplace_reorganize (meta : Meta.meta) (config : config) (expand_prim_c ctx (** Convert an operand constant operand value to a typed value *) -let literal_to_typed_value (ty : literal_type) (cv : literal) : typed_value = +let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) : typed_value = (* Check the type while converting - we actually need some information * contained in the type *) log#ldebug @@ -100,11 +101,11 @@ let literal_to_typed_value (ty : literal_type) (cv : literal) : typed_value = | TChar, VChar v -> { value = VLiteral (VChar v); ty = TLiteral ty } | TInteger int_ty, VScalar v -> (* Check the type and the ranges *) - assert (int_ty = v.int_ty); - assert (check_scalar_value_in_range v); + cassert (int_ty = v.int_ty) meta "Wrong type TODO: error message"; + cassert (check_scalar_value_in_range v) meta "Wrong range TODO: error message"; { value = VLiteral (VScalar v); ty = TLiteral ty } (* Remaining cases (invalid) *) - | _, _ -> raise (Failure "Improperly typed constant value") + | _, _ -> craise meta "Improperly typed constant value" (** Copy a value, and return the resulting value. @@ -117,13 +118,13 @@ let literal_to_typed_value (ty : literal_type) (cv : literal) : typed_value = parameter to control this copy ([allow_adt_copy]). Note that here by ADT we mean the user-defined ADTs (not tuples or assumed types). *) -let rec copy_value (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) +let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) (v : typed_value) : eval_ctx * typed_value = log#ldebug (lazy ("copy_value: " - ^ typed_value_to_string ctx v - ^ "\n- context:\n" ^ eval_ctx_to_string ctx)); + ^ typed_value_to_string meta ctx v + ^ "\n- context:\n" ^ eval_ctx_to_string meta ctx)); (* Remark: at some point we rewrote this function to use iterators, but then * we reverted the changes: the result was less clear actually. In particular, * the fact that we have exhaustive matches below makes very obvious the cases @@ -134,9 +135,9 @@ let rec copy_value (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) (* Sanity check *) (match v.ty with | TAdt (TAssumed TBox, _) -> - raise (Failure "Can't copy an assumed value other than Option") + craise meta "Can't copy an assumed value other than Option" | TAdt (TAdtId _, _) as ty -> - assert (allow_adt_copy || ty_is_primitively_copyable ty) + cassert (allow_adt_copy || ty_is_primitively_copyable ty) meta "TODO: error message" | TAdt (TTuple, _) -> () (* Ok *) | TAdt ( TAssumed (TSlice | TArray), @@ -146,15 +147,15 @@ let rec copy_value (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) const_generics = []; trait_refs = []; } ) -> - assert (ty_is_primitively_copyable ty) - | _ -> raise (Failure "Unreachable")); + cassert (ty_is_primitively_copyable ty) meta "TODO: error message" + | _ -> craise meta "Unreachable"); let ctx, fields = List.fold_left_map - (copy_value allow_adt_copy config) + (copy_value meta allow_adt_copy config) ctx av.field_values in (ctx, { v with value = VAdt { av with field_values = fields } }) - | VBottom -> raise (Failure "Can't copy ⊥") + | VBottom -> craise meta "Can't copy ⊥" | VBorrow bc -> ( (* We can only copy shared borrows *) match bc with @@ -162,24 +163,24 @@ let rec copy_value (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) (* We need to create a new borrow id for the copied borrow, and * update the context accordingly *) let bid' = fresh_borrow_id () in - let ctx = InterpreterBorrows.reborrow_shared bid bid' ctx in + let ctx = InterpreterBorrows.reborrow_shared meta bid bid' ctx in (ctx, { v with value = VBorrow (VSharedBorrow bid') }) - | VMutBorrow (_, _) -> raise (Failure "Can't copy a mutable borrow") + | VMutBorrow (_, _) -> craise meta "Can't copy a mutable borrow" | VReservedMutBorrow _ -> - raise (Failure "Can't copy a reserved mut borrow")) + craise meta "Can't copy a reserved mut borrow") | VLoan lc -> ( (* We can only copy shared loans *) match lc with - | VMutLoan _ -> raise (Failure "Can't copy a mutable loan") + | VMutLoan _ -> craise meta "Can't copy a mutable loan" | VSharedLoan (_, sv) -> (* We don't copy the shared loan: only the shared value inside *) - copy_value allow_adt_copy config ctx sv) + copy_value meta allow_adt_copy config ctx sv) | VSymbolic sp -> (* We can copy only if the type is "primitively" copyable. * Note that in the general case, copy is a trait: copying values * thus requires calling the proper function. Here, we copy values * for very simple types such as integers, shared borrows, etc. *) - assert (ty_is_primitively_copyable (Substitute.erase_regions sp.sv_ty)); + cassert (ty_is_primitively_copyable (Substitute.erase_regions sp.sv_ty)) meta "Not primitively copyable"; (* If the type is copyable, we simply return the current value. Side * remark: what is important to look at when copying symbolic values * is symbolic expansion. The important subcase is the expansion of shared @@ -248,25 +249,25 @@ let prepare_eval_operand_reorganize (meta : Meta.meta) (config : config) (op : o prepare cf ctx (** Evaluate an operand, without reorganizing the context before *) -let eval_operand_no_reorganize (config : config) (op : operand) +let eval_operand_no_reorganize (meta : Meta.meta) (config : config) (op : operand) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("eval_operand_no_reorganize: op: " ^ operand_to_string ctx op - ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); + ^ "\n- ctx:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); (* Evaluate *) match op with | Constant cv -> ( match cv.value with | CLiteral lit -> - cf (literal_to_typed_value (ty_as_literal cv.ty) lit) ctx + cf (literal_to_typed_value meta (ty_as_literal cv.ty) lit) ctx | CTraitConst (trait_ref, const_name) -> ( let ctx0 = ctx in (* Simply introduce a fresh symbolic value *) let ty = cv.ty in - let v = mk_fresh_symbolic_typed_value ty in + let v = mk_fresh_symbolic_typed_value meta ty in (* Continue the evaluation *) let e = cf v ctx in (* Wrap the generated expression *) @@ -277,7 +278,7 @@ let eval_operand_no_reorganize (config : config) (op : operand) (SymbolicAst.IntroSymbolic ( ctx0, None, - value_as_symbolic v.value, + value_as_symbolic meta v.value, SymbolicAst.VaTraitConstValue (trait_ref, const_name), e ))) | CVar vid -> ( @@ -294,49 +295,49 @@ let eval_operand_no_reorganize (config : config) (op : operand) | ConcreteMode -> (* Copy the value - this is more of a sanity check *) let allow_adt_copy = false in - copy_value allow_adt_copy config ctx cv + copy_value meta allow_adt_copy config ctx cv | SymbolicMode -> (* We use the looked up value only for its type *) - let v = mk_fresh_symbolic_typed_value cv.ty in + let v = mk_fresh_symbolic_typed_value meta cv.ty in (ctx, v) in (* Continue *) let e = cf cv ctx in (* If we are synthesizing a symbolic AST, it means that we are in symbolic mode: the value of the const generic is necessarily symbolic. *) - assert (e = None || is_symbolic cv.value); + cassert (e = None || is_symbolic cv.value) meta "The value of the const generic should be symbolic"; (* We have to wrap the generated expression *) match e with | None -> None | Some e -> (* If we are synthesizing a symbolic AST, it means that we are in symbolic mode: the value of the const generic is necessarily symbolic. *) - assert (is_symbolic cv.value); + cassert (is_symbolic cv.value) meta "The value of the const generic should be symbolic"; (* *) Some (SymbolicAst.IntroSymbolic ( ctx0, None, - value_as_symbolic cv.value, + value_as_symbolic meta cv.value, SymbolicAst.VaCgValue vid, e ))) - | CFnPtr _ -> raise (Failure "TODO")) + | CFnPtr _ -> craise meta "TODO") | Copy p -> (* Access the value *) let access = Read in - let cc = read_place access p in + let cc = read_place meta access p in (* Copy the value *) let copy cf v : m_fun = fun ctx -> (* Sanity checks *) - assert (not (bottom_in_value ctx.ended_regions v)); - assert ( + cassert (not (bottom_in_value ctx.ended_regions v)) meta "TODO: error message"; + cassert ( Option.is_none (find_first_primitively_copyable_sv_with_borrows - ctx.type_ctx.type_infos v)); + ctx.type_ctx.type_infos v)) meta "TODO: error message"; (* Actually perform the copy *) let allow_adt_copy = false in - let ctx, v = copy_value allow_adt_copy config ctx v in + let ctx, v = copy_value meta allow_adt_copy config ctx v in (* Continue *) cf v ctx in @@ -345,14 +346,14 @@ let eval_operand_no_reorganize (config : config) (op : operand) | Move p -> (* Access the value *) let access = Move in - let cc = read_place access p in + let cc = read_place meta access p in (* Move the value *) let move cf v : m_fun = fun ctx -> (* Check that there are no bottoms in the value we are about to move *) - assert (not (bottom_in_value ctx.ended_regions v)); + cassert (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value we are about to move"; let bottom : typed_value = { value = VBottom; ty = v.ty } in - let ctx = write_place access p bottom ctx in + let ctx = write_place meta access p bottom ctx in cf v ctx in (* Compose and apply *) @@ -365,11 +366,11 @@ let eval_operand (meta : Meta.meta) (config : config) (op : operand) (cf : type log#ldebug (lazy ("eval_operand: op: " ^ operand_to_string ctx op ^ "\n- ctx:\n" - ^ eval_ctx_to_string ctx ^ "\n")); + ^ eval_ctx_to_string meta ctx ^ "\n")); (* We reorganize the context, then evaluate the operand *) comp (prepare_eval_operand_reorganize meta config op) - (eval_operand_no_reorganize config op) + (eval_operand_no_reorganize meta config op) cf ctx (** Small utility. @@ -388,7 +389,7 @@ let eval_operands (meta : Meta.meta) (config : config) (ops : operand list) let prepare = prepare_eval_operands_reorganize meta config ops in (* Evaluate the operands *) let eval = - fold_left_list_apply_continuation (eval_operand_no_reorganize config) ops + fold_left_list_apply_continuation (eval_operand_no_reorganize meta config) ops in (* Compose and apply *) comp prepare eval cf ctx @@ -399,7 +400,7 @@ let eval_two_operands (meta : Meta.meta) (config : config) (op1 : operand) (op2 let use_res cf res = match res with | [ v1; v2 ] -> cf (v1, v2) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in comp eval_op use_res cf @@ -420,7 +421,7 @@ let eval_unary_op_concrete (meta : Meta.meta) (config : config) (unop : unop) (o | ( Cast (CastScalar (TInteger src_ty, TInteger tgt_ty)), VLiteral (VScalar sv) ) -> ( (* Cast between integers *) - assert (src_ty = sv.int_ty); + cassert (src_ty = sv.int_ty) meta "TODO: error message"; let i = sv.value in match mk_scalar tgt_ty i with | Error _ -> cf (Error EPanic) @@ -442,12 +443,12 @@ let eval_unary_op_concrete (meta : Meta.meta) (config : config) (unop : unop) (o let b = if Z.of_int 0 = sv.value then false else if Z.of_int 1 = sv.value then true - else raise (Failure "Conversion from int to bool: out of range") + else craise meta "Conversion from int to bool: out of range" in let value = VLiteral (VBool b) in let ty = TLiteral TBool in cf (Ok { ty; value }) - | _ -> raise (Failure "Invalid input for unop") + | _ -> craise meta "Invalid input for unop" in comp eval_op apply cf @@ -465,7 +466,7 @@ let eval_unary_op_symbolic (meta : Meta.meta) (config : config) (unop : unop) (o | Not, (TLiteral TBool as lty) -> lty | Neg, (TLiteral (TInteger _) as lty) -> lty | Cast (CastScalar (_, tgt_ty)), _ -> TLiteral tgt_ty - | _ -> raise (Failure "Invalid input for unop") + | _ -> craise meta "Invalid input for unop" in let res_sv = { sv_id = res_sv_id; sv_ty = res_sv_ty } in (* Call the continuation *) @@ -487,15 +488,15 @@ let eval_unary_op (meta : Meta.meta) (config : config) (unop : unop) (op : opera (** Small helper for [eval_binary_op_concrete]: computes the result of applying the binop *after* the operands have been successfully evaluated *) -let eval_binary_op_concrete_compute (binop : binop) (v1 : typed_value) +let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typed_value) (v2 : typed_value) : (typed_value, eval_error) result = (* Equality check binops (Eq, Ne) accept values from a wide variety of types. * The remaining binops only operate on scalars. *) if binop = Eq || binop = Ne then ( (* Equality operations *) - assert (v1.ty = v2.ty); + cassert (v1.ty = v2.ty) meta "TODO: error message"; (* Equality/inequality check is primitive only for a subset of types *) - assert (ty_is_primitively_copyable v1.ty); + cassert (ty_is_primitively_copyable v1.ty) meta "Not primitively copyable TODO: error message"; let b = v1 = v2 in Ok { value = VLiteral (VBool b); ty = TLiteral TBool }) else @@ -510,7 +511,7 @@ let eval_binary_op_concrete_compute (binop : binop) (v1 : typed_value) match binop with | Lt | Le | Ge | Gt -> (* The two operands must have the same type and the result is a boolean *) - assert (sv1.int_ty = sv2.int_ty); + cassert (sv1.int_ty = sv2.int_ty) meta "The two operands must have the same type and the result is a boolean"; let b = match binop with | Lt -> Z.lt sv1.value sv2.value @@ -519,14 +520,14 @@ let eval_binary_op_concrete_compute (binop : binop) (v1 : typed_value) | Gt -> Z.gt sv1.value sv2.value | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr | Shl | Shr | Ne | Eq -> - raise (Failure "Unreachable") + craise meta "Unreachable" in Ok ({ value = VLiteral (VBool b); ty = TLiteral TBool } : typed_value) | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> ( (* The two operands must have the same type and the result is an integer *) - assert (sv1.int_ty = sv2.int_ty); + cassert (sv1.int_ty = sv2.int_ty) meta "The two operands must have the same type and the result is an integer"; let res = match binop with | Div -> @@ -543,7 +544,7 @@ let eval_binary_op_concrete_compute (binop : binop) (v1 : typed_value) | BitAnd -> raise Unimplemented | BitOr -> raise Unimplemented | Lt | Le | Ge | Gt | Shl | Shr | Ne | Eq -> - raise (Failure "Unreachable") + craise meta "Unreachable" in match res with | Error _ -> Error EPanic @@ -554,8 +555,8 @@ let eval_binary_op_concrete_compute (binop : binop) (v1 : typed_value) ty = TLiteral (TInteger sv1.int_ty); }) | Shl | Shr -> raise Unimplemented - | Ne | Eq -> raise (Failure "Unreachable")) - | _ -> raise (Failure "Invalid inputs for binop") + | Ne | Eq -> craise meta "Unreachable") + | _ -> craise meta "Invalid inputs for binop" let eval_binary_op_concrete (meta : Meta.meta) (config : config) (binop : binop) (op1 : operand) (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = @@ -564,7 +565,7 @@ let eval_binary_op_concrete (meta : Meta.meta) (config : config) (binop : binop) (* Compute the result of the binop *) let compute cf (res : typed_value * typed_value) = let v1, v2 = res in - cf (eval_binary_op_concrete_compute binop v1 v2) + cf (eval_binary_op_concrete_compute meta binop v1 v2) in (* Compose and apply *) comp eval_ops compute cf @@ -582,9 +583,9 @@ let eval_binary_op_symbolic (meta : Meta.meta) (config : config) (binop : binop) let res_sv_ty = if binop = Eq || binop = Ne then ( (* Equality operations *) - assert (v1.ty = v2.ty); + cassert (v1.ty = v2.ty) meta "TODO: error message"; (* Equality/inequality check is primitive only for a subset of types *) - assert (ty_is_primitively_copyable v1.ty); + cassert (ty_is_primitively_copyable v1.ty) meta "Not primitively copyable TODO: error message"; TLiteral TBool) else (* Other operations: input types are integers *) @@ -592,17 +593,17 @@ let eval_binary_op_symbolic (meta : Meta.meta) (config : config) (binop : binop) | TLiteral (TInteger int_ty1), TLiteral (TInteger int_ty2) -> ( match binop with | Lt | Le | Ge | Gt -> - assert (int_ty1 = int_ty2); + cassert (int_ty1 = int_ty2) meta "TODO: error message"; TLiteral TBool | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> - assert (int_ty1 = int_ty2); + cassert (int_ty1 = int_ty2) meta "TODO: error message"; TLiteral (TInteger int_ty1) | Shl | Shr -> (* The number of bits can be of a different integer type than the operand *) TLiteral (TInteger int_ty1) - | Ne | Eq -> raise (Failure "Unreachable")) - | _ -> raise (Failure "Invalid inputs for binop") + | Ne | Eq -> craise meta "Unreachable") + | _ -> craise meta "Invalid inputs for binop" in let res_sv = { sv_id = res_sv_id; sv_ty = res_sv_ty } in (* Call the continuattion *) @@ -631,14 +632,14 @@ let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : bo In practice this restricted the behaviour too much, so for now we forbid them. *) - assert (bkind <> BShallow); + cassert (bkind <> BShallow) meta "Shallow borrow are currently forbidden"; (* Access the value *) let access = match bkind with | BShared | BShallow -> Read | BTwoPhaseMut -> Write - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in let expand_prim_copy = false in @@ -663,14 +664,14 @@ let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : bo { v with value = v' } in (* Update the borrowed value in the context *) - let ctx = write_place access p nv ctx in + let ctx = write_place meta access p nv ctx in (* Compute the rvalue - simply a shared borrow with a the fresh id. * Note that the reference is *mutable* if we do a two-phase borrow *) let ref_kind = match bkind with | BShared | BShallow -> RShared | BTwoPhaseMut -> RMut - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in let rv_ty = TRef (RErased, v.ty, ref_kind) in let bc = @@ -680,7 +681,7 @@ let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : bo handle shallow borrows like shared borrows *) VSharedBorrow bid | BTwoPhaseMut -> VReservedMutBorrow bid - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in let rv : typed_value = { value = VBorrow bc; ty = rv_ty } in (* Continue *) @@ -707,7 +708,7 @@ let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : bo (* Compute the value with which to replace the value at place p *) let nv = { v with value = VLoan (VMutLoan bid) } in (* Update the value in the context *) - let ctx = write_place access p nv ctx in + let ctx = write_place meta access p nv ctx in (* Continue *) cf rv ctx in @@ -736,16 +737,16 @@ let eval_rvalue_aggregate (meta : Meta.meta) (config : config) (aggregate_kind : | TAdtId def_id -> (* Sanity checks *) let type_decl = ctx_lookup_type_decl ctx def_id in - assert ( + cassert ( List.length type_decl.generics.regions - = List.length generics.regions); + = List.length generics.regions) meta "TODO: error message"; let expected_field_types = AssociatedTypes.ctx_adt_get_inst_norm_field_etypes ctx def_id opt_variant_id generics in - assert ( + cassert ( expected_field_types - = List.map (fun (v : typed_value) -> v.ty) values); + = List.map (fun (v : typed_value) -> v.ty) values) meta "TODO: error message"; (* Construct the value *) let av : adt_value = { variant_id = opt_variant_id; field_values = values } @@ -754,13 +755,13 @@ let eval_rvalue_aggregate (meta : Meta.meta) (config : config) (aggregate_kind : let aggregated : typed_value = { value = VAdt av; ty = aty } in (* Call the continuation *) cf aggregated ctx - | TAssumed _ -> raise (Failure "Unreachable")) + | TAssumed _ -> craise meta "Unreachable") | AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) - assert (List.for_all (fun (v : typed_value) -> v.ty = ety) values); + cassert (List.for_all (fun (v : typed_value) -> v.ty = ety) values) meta "All the values do not have the proper type"; (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in - assert (len = Z.of_int (List.length values)); + cassert (len = Z.of_int (List.length values)) meta "The number of values is not consistent with the length"; let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in let ty = TAdt (TAssumed TArray, generics) in (* In order to generate a better AST, we introduce a symbolic @@ -768,15 +769,15 @@ let eval_rvalue_aggregate (meta : Meta.meta) (config : config) (aggregate_kind : array we introduce here might be duplicated in the generated code: by introducing a symbolic value we introduce a let-binding in the generated code. *) - let saggregated = mk_fresh_symbolic_typed_value ty in + let saggregated = mk_fresh_symbolic_typed_value meta ty in (* Call the continuation *) match cf saggregated ctx with | None -> None | Some e -> (* Introduce the symbolic value in the AST *) - let sv = ValuesUtils.value_as_symbolic saggregated.value in + let sv = ValuesUtils.value_as_symbolic meta saggregated.value in Some (SymbolicAst.IntroSymbolic (ctx, None, sv, VaArray values, e))) - | AggregatedClosure _ -> raise (Failure "Closures are not supported yet") + | AggregatedClosure _ -> craise meta "Closures are not supported yet" in (* Compose and apply *) comp eval_ops compute cf @@ -800,11 +801,11 @@ let eval_rvalue_not_global (meta : Meta.meta) (config : config) (rvalue : rvalue | Aggregate (aggregate_kind, ops) -> comp_wrap (eval_rvalue_aggregate meta config aggregate_kind ops) ctx | Discriminant _ -> - raise - (Failure + craise + meta "Unreachable: discriminant reads should have been eliminated from \ - the AST") - | Global _ -> raise (Failure "Unreachable") + the AST" + | Global _ -> craise meta "Unreachable" let eval_fake_read (meta : Meta.meta) (config : config) (p : place) : cm_fun = fun cf ctx -> @@ -814,7 +815,7 @@ let eval_fake_read (meta : Meta.meta) (config : config) (p : place) : cm_fun = in let cf_continue cf v : m_fun = fun ctx -> - assert (not (bottom_in_value ctx.ended_regions v)); + cassert (not (bottom_in_value ctx.ended_regions v)) meta "TODO: error message"; cf ctx in comp cf_prepare cf_continue cf ctx diff --git a/compiler/InterpreterExpressions.mli b/compiler/InterpreterExpressions.mli index b975371c..69455682 100644 --- a/compiler/InterpreterExpressions.mli +++ b/compiler/InterpreterExpressions.mli @@ -12,7 +12,7 @@ open InterpreterPaths This function doesn't reorganize the context to make sure we can read the place. If needs be, you should call {!InterpreterPaths.update_ctx_along_read_place} first. *) -val read_place : access_kind -> place -> (typed_value -> m_fun) -> m_fun +val read_place : Meta.meta -> access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Auxiliary function. @@ -31,7 +31,7 @@ val read_place : access_kind -> place -> (typed_value -> m_fun) -> m_fun primitively copyable and contain borrows. *) val access_rplace_reorganize_and_read : - config -> bool -> access_kind -> place -> (typed_value -> m_fun) -> m_fun + Meta.meta -> config -> bool -> access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Evaluate an operand. @@ -42,11 +42,11 @@ val access_rplace_reorganize_and_read : of the environment, before evaluating all the operands at once. Use {!eval_operands} instead. *) -val eval_operand : config -> operand -> (typed_value -> m_fun) -> m_fun +val eval_operand : Meta.meta -> config -> operand -> (typed_value -> m_fun) -> m_fun (** Evaluate several operands at once. *) val eval_operands : - config -> operand list -> (typed_value list -> m_fun) -> m_fun + Meta.meta -> config -> operand list -> (typed_value list -> m_fun) -> m_fun (** Evaluate an rvalue which is not a global (globals are handled elsewhere). @@ -56,7 +56,7 @@ val eval_operands : reads should have been eliminated from the AST. *) val eval_rvalue_not_global : - config -> rvalue -> ((typed_value, eval_error) result -> m_fun) -> m_fun + Meta.meta -> config -> rvalue -> ((typed_value, eval_error) result -> m_fun) -> m_fun (** Evaluate a fake read (update the context so that we can read a place) *) -val eval_fake_read : config -> place -> cm_fun +val eval_fake_read : Meta.meta -> config -> place -> cm_fun diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index afbe0501..98aa0e14 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -9,12 +9,13 @@ open InterpreterUtils open InterpreterLoopsCore open InterpreterLoopsMatchCtxs open InterpreterLoopsFixedPoint +open Errors (** The local logger *) let log = Logging.loops_log (** Evaluate a loop in concrete mode *) -let eval_loop_concrete (eval_loop_body : st_cm_fun) : st_cm_fun = +let eval_loop_concrete (meta : Meta.meta) (eval_loop_body : st_cm_fun) : st_cm_fun = fun cf ctx -> (* We need a loop id for the [LoopReturn]. In practice it won't be used (it is useful only for the symbolic execution *) @@ -52,10 +53,10 @@ let eval_loop_concrete (eval_loop_body : st_cm_fun) : st_cm_fun = * {!Unit} would account for the first iteration of the loop. * We prefer to write it this way for consistency and sanity, * though. *) - raise (Failure "Unreachable") + craise meta "Unreachable" | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> (* We can't get there: this is only used in symbolic mode *) - raise (Failure "Unreachable") + craise meta "Unreachable" in (* Apply *) @@ -67,24 +68,24 @@ let eval_loop_symbolic (config : config) (meta : meta) fun cf ctx -> (* Debug *) log#ldebug - (lazy ("eval_loop_symbolic:\nContext:\n" ^ eval_ctx_to_string ctx ^ "\n\n")); + (lazy ("eval_loop_symbolic:\nContext:\n" ^ eval_ctx_to_string meta ctx ^ "\n\n")); (* Generate a fresh loop id *) let loop_id = fresh_loop_id () in (* Compute the fixed point at the loop entrance *) let fp_ctx, fixed_ids, rg_to_abs = - compute_loop_entry_fixed_point config loop_id eval_loop_body ctx + compute_loop_entry_fixed_point meta config loop_id eval_loop_body ctx in (* Debug *) log#ldebug (lazy - ("eval_loop_symbolic:\nInitial context:\n" ^ eval_ctx_to_string ctx - ^ "\n\nFixed point:\n" ^ eval_ctx_to_string fp_ctx)); + ("eval_loop_symbolic:\nInitial context:\n" ^ eval_ctx_to_string meta ctx + ^ "\n\nFixed point:\n" ^ eval_ctx_to_string meta fp_ctx)); (* Compute the loop input parameters *) - let fresh_sids, input_svalues = compute_fp_ctx_symbolic_values ctx fp_ctx in + let fresh_sids, input_svalues = compute_fp_ctx_symbolic_values meta ctx fp_ctx in let fp_input_svalues = List.map (fun sv -> sv.sv_id) input_svalues in (* Synthesize the end of the function - we simply match the context at the @@ -115,16 +116,16 @@ let eval_loop_symbolic (config : config) (meta : meta) (* Compute the id correspondance between the contexts *) let fp_bl_corresp = - compute_fixed_point_id_correspondance fixed_ids ctx fp_ctx + compute_fixed_point_id_correspondance meta fixed_ids ctx fp_ctx in log#ldebug (lazy ("eval_loop_symbolic: about to match the fixed-point context with the \ original context:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string fp_ctx - ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string ctx)); + - src ctx (fixed-point ctx)" ^ eval_ctx_to_string meta fp_ctx + ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string meta ctx)); let end_expr : SymbolicAst.expression option = - match_ctx_with_target config loop_id true fp_bl_corresp fp_input_svalues + match_ctx_with_target meta config loop_id true fp_bl_corresp fp_input_svalues fixed_ids fp_ctx cf ctx in log#ldebug @@ -149,15 +150,15 @@ let eval_loop_symbolic (config : config) (meta : meta) cf res ctx | Continue i -> (* We don't support nested loops for now *) - assert (i = 0); + cassert (i = 0) meta "Nested loops are not supported yet"; log#ldebug (lazy ("eval_loop_symbolic: about to match the fixed-point context \ with the context at a continue:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string fp_ctx - ^ "\n\n-tgt ctx (ctx at continue):\n" ^ eval_ctx_to_string ctx)); + - src ctx (fixed-point ctx)" ^ eval_ctx_to_string meta fp_ctx + ^ "\n\n-tgt ctx (ctx at continue):\n" ^ eval_ctx_to_string meta ctx)); let cc = - match_ctx_with_target config loop_id false fp_bl_corresp + match_ctx_with_target meta config loop_id false fp_bl_corresp fp_input_svalues fixed_ids fp_ctx in cc cf ctx @@ -165,16 +166,16 @@ let eval_loop_symbolic (config : config) (meta : meta) (* For why we can't get [Unit], see the comments inside {!eval_loop_concrete}. For [EndEnterLoop] and [EndContinue]: we don't support nested loops for now. *) - raise (Failure "Unreachable") + craise meta "Unreachable" in let loop_expr = eval_loop_body cf_loop fp_ctx in log#ldebug (lazy ("eval_loop_symbolic: result:" ^ "\n- src context:\n" - ^ eval_ctx_to_string_no_filter ctx + ^ eval_ctx_to_string_no_filter meta ctx ^ "\n- fixed point:\n" - ^ eval_ctx_to_string_no_filter fp_ctx + ^ eval_ctx_to_string_no_filter meta fp_ctx ^ "\n- fixed_sids: " ^ SymbolicValueId.Set.show fixed_ids.sids ^ "\n- fresh_sids: " @@ -199,7 +200,7 @@ let eval_loop_symbolic (config : config) (meta : meta) match av.value with | ABorrow _ -> true | ALoan _ -> false - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in let borrows, loans = List.partition is_borrow abs.avalues in @@ -208,10 +209,10 @@ let eval_loop_symbolic (config : config) (meta : meta) (fun (av : typed_avalue) -> match av.value with | ABorrow (AMutBorrow (bid, child_av)) -> - assert (is_aignored child_av.value); + cassert (is_aignored child_av.value) meta "TODO: error message"; Some (bid, child_av.ty) | ABorrow (ASharedBorrow _) -> None - | _ -> raise (Failure "Unreachable")) + | _ -> craise meta "Unreachable") borrows in let borrows = ref (BorrowId.Map.of_list borrows) in @@ -221,10 +222,10 @@ let eval_loop_symbolic (config : config) (meta : meta) (fun (av : typed_avalue) -> match av.value with | ALoan (AMutLoan (bid, child_av)) -> - assert (is_aignored child_av.value); + cassert (is_aignored child_av.value) meta "TODO: error message"; Some bid | ALoan (ASharedLoan _) -> None - | _ -> raise (Failure "Unreachable")) + | _ -> craise meta "Unreachable") loans in @@ -240,7 +241,7 @@ let eval_loop_symbolic (config : config) (meta : meta) ty) loan_ids in - assert (BorrowId.Map.is_empty !borrows); + cassert (BorrowId.Map.is_empty !borrows) meta "TODO: error message"; given_back_tys in @@ -259,7 +260,7 @@ let eval_loop (config : config) (meta : meta) (eval_loop_body : st_cm_fun) : st_cm_fun = fun cf ctx -> match config.mode with - | ConcreteMode -> eval_loop_concrete eval_loop_body cf ctx + | ConcreteMode -> eval_loop_concrete meta eval_loop_body cf ctx | SymbolicMode -> (* Simplify the context by ending the unnecessary borrows/loans and getting rid of the useless symbolic values (which are in anonymous variables) *) @@ -283,5 +284,5 @@ let eval_loop (config : config) (meta : meta) (eval_loop_body : st_cm_fun) : introduce *fixed* abstractions, and again later to introduce *non-fixed* abstractions. *) - let cc = comp cc (prepare_ashared_loans None) in + let cc = comp cc (prepare_ashared_loans meta None) in comp cc (eval_loop_symbolic config meta eval_loop_body) cf ctx diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 0bd57756..3e887741 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -4,6 +4,7 @@ open Types open Values open Contexts open InterpreterUtils +open Errors type updt_env_kind = | AbsInLeft of AbstractionId.id @@ -57,11 +58,11 @@ module type PrimMatcher = sig (** The input primitive values are not equal *) val match_distinct_literals : - eval_ctx -> eval_ctx -> ety -> literal -> literal -> typed_value + Meta.meta -> eval_ctx -> eval_ctx -> ety -> literal -> literal -> typed_value (** The input ADTs don't have the same variant *) val match_distinct_adts : - eval_ctx -> eval_ctx -> ety -> adt_value -> adt_value -> typed_value + Meta.meta -> eval_ctx -> eval_ctx -> ety -> adt_value -> adt_value -> typed_value (** The meta-value is the result of a match. @@ -74,6 +75,7 @@ module type PrimMatcher = sig calling the match function. *) val match_shared_borrows : + Meta.meta -> eval_ctx -> eval_ctx -> (typed_value -> typed_value -> typed_value) -> @@ -91,6 +93,7 @@ module type PrimMatcher = sig - [bv]: the result of matching [bv0] with [bv1] *) val match_mut_borrows : + Meta.meta -> eval_ctx -> eval_ctx -> ety -> @@ -121,7 +124,7 @@ module type PrimMatcher = sig (** There are no constraints on the input symbolic values *) val match_symbolic_values : - eval_ctx -> eval_ctx -> symbolic_value -> symbolic_value -> symbolic_value + Meta.meta -> eval_ctx -> eval_ctx -> symbolic_value -> symbolic_value -> symbolic_value (** Match a symbolic value with a value which is not symbolic. @@ -131,7 +134,7 @@ module type PrimMatcher = sig end loans in one of the two environments). *) val match_symbolic_with_other : - eval_ctx -> eval_ctx -> bool -> symbolic_value -> typed_value -> typed_value + Meta.meta -> eval_ctx -> eval_ctx -> bool -> symbolic_value -> typed_value -> typed_value (** Match a bottom value with a value which is not bottom. @@ -141,10 +144,11 @@ module type PrimMatcher = sig end loans in one of the two environments). *) val match_bottom_with_other : - eval_ctx -> eval_ctx -> bool -> typed_value -> typed_value + Meta.meta -> eval_ctx -> eval_ctx -> bool -> typed_value -> typed_value (** The input ADTs don't have the same variant *) val match_distinct_aadts : + Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -162,6 +166,7 @@ module type PrimMatcher = sig [ty]: result of matching ty0 and ty1 *) val match_ashared_borrows : + Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -182,6 +187,7 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_amut_borrows : + Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -208,6 +214,7 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_ashared_loans : + Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -234,6 +241,7 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_amut_loans : + Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -250,7 +258,7 @@ module type PrimMatcher = sig is typically used to raise the proper exception). *) val match_avalues : - eval_ctx -> eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue + Meta.meta -> eval_ctx -> eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue end module type Matcher = sig @@ -259,14 +267,14 @@ module type Matcher = sig Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) val match_typed_values : - eval_ctx -> eval_ctx -> typed_value -> typed_value -> typed_value + Meta.meta -> eval_ctx -> eval_ctx -> typed_value -> typed_value -> typed_value (** Match two avalues. Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) val match_typed_avalues : - eval_ctx -> eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue + Meta.meta -> eval_ctx -> eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue end (** See {!module:InterpreterLoopsMatchCtxs.MakeCheckEquivMatcher} and @@ -351,7 +359,7 @@ end Returns: (fixed, new abs, new dummies) *) -let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : eval_ctx) : +let ctx_split_fixed_new (meta : Meta.meta) (fixed_ids : ids_sets) (ctx : eval_ctx) : env * abs list * typed_value list = let is_fresh_did (id : DummyVarId.id) : bool = not (DummyVarId.Set.mem id fixed_ids.dids) @@ -373,7 +381,7 @@ let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : eval_ctx) : let new_absl = List.map (fun ee -> - match ee with EAbs abs -> abs | _ -> raise (Failure "Unreachable")) + match ee with EAbs abs -> abs | _ -> craise meta "Unreachable") new_absl in let new_dummyl = @@ -381,7 +389,7 @@ let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : eval_ctx) : (fun ee -> match ee with | EBinding (BDummy _, v) -> v - | _ -> raise (Failure "Unreachable")) + | _ -> craise meta "Unreachable") new_dummyl in (filt_env, new_absl, new_dummyl) diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 35582456..508d0f0c 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -215,7 +215,7 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f (* Remove the shared loans *) let v = value_remove_shared_loans v in (* Substitute the symbolic values and the region *) - Substitute.typed_value_subst_ids + Substitute.typed_value_subst_ids meta (fun r -> if RegionId.Set.mem r rids then nrid else r) (fun x -> x) (fun x -> x) @@ -267,9 +267,9 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f borrow_substs := (lid, nlid) :: !borrow_substs; (* Rem.: the below sanity checks are not really necessary *) - cassert (AbstractionId.Set.is_empty abs.parents) meta "abs.parents is not empty TODO"; - cassert (abs.original_parents = []) meta "original_parents is not empty TODO"; - cassert (RegionId.Set.is_empty abs.ancestors_regions) meta "ancestors_regions is not empty TODO"; + cassert (AbstractionId.Set.is_empty abs.parents) meta "abs.parents is not empty TODO: Error message"; + cassert (abs.original_parents = []) meta "original_parents is not empty TODO: Error message"; + cassert (RegionId.Set.is_empty abs.ancestors_regions) meta "ancestors_regions is not empty TODO: Error message"; (* Introduce the new abstraction for the shared values *) cassert (ty_no_regions sv.ty) meta "TODO : error message "; @@ -277,19 +277,19 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f (* Create the shared loan child *) let child_rty = rty in - let child_av = mk_aignored child_rty in + let child_av = mk_aignored meta child_rty in (* Create the shared loan *) let loan_rty = TRef (RFVar nrid, rty, RShared) in let loan_value = ALoan (ASharedLoan (BorrowId.Set.singleton nlid, nsv, child_av)) in - let loan_value = mk_typed_avalue loan_rty loan_value in + let loan_value = mk_typed_avalue meta loan_rty loan_value in (* Create the shared borrow *) let borrow_rty = loan_rty in let borrow_value = ABorrow (ASharedBorrow lid) in - let borrow_value = mk_typed_avalue borrow_rty borrow_value in + let borrow_value = mk_typed_avalue meta borrow_rty borrow_value in (* Create the abstraction *) let avalues = [ borrow_value; loan_value ] in @@ -435,7 +435,7 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f let prepare_ashared_loans_no_synth (meta : Meta.meta) (loop_id : LoopId.id) (ctx : eval_ctx) : eval_ctx = - get_cf_ctx_no_synth (prepare_ashared_loans meta (Some loop_id)) ctx + get_cf_ctx_no_synth meta (prepare_ashared_loans meta (Some loop_id)) ctx let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id : LoopId.id) (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : @@ -461,9 +461,9 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (lazy ("compute_loop_entry_fixed_point: after prepare_ashared_loans:" ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter ctx0 + ^ eval_ctx_to_string_no_filter meta ctx0 ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter ctx + ^ eval_ctx_to_string_no_filter meta ctx ^ "\n\n")); let cf_exit_loop_body (res : statement_eval_res) : m_fun = @@ -510,10 +510,10 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (* End those borrows and abstractions *) let end_borrows_abs blids aids ctx = let ctx = - InterpreterBorrows.end_borrows_no_synth config blids ctx + InterpreterBorrows.end_borrows_no_synth meta config blids ctx in let ctx = - InterpreterBorrows.end_abstractions_no_synth config aids ctx + InterpreterBorrows.end_abstractions_no_synth meta config aids ctx in ctx in @@ -544,7 +544,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (* Join the context with the context at the loop entry *) let (_, _), ctx2 = - loop_join_origin_with_continue_ctxs config loop_id fixed_ids ctx1 !ctxs + loop_join_origin_with_continue_ctxs meta config loop_id fixed_ids ctx1 !ctxs in ctxs := []; ctx2 @@ -576,7 +576,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id let check_equivalent = true in let lookup_shared_value _ = craise meta "Unreachable" in Option.is_some - (match_ctxs check_equivalent fixed_ids lookup_shared_value + (match_ctxs meta check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx1 ctx2) in let max_num_iter = Config.loop_fixed_point_max_num_iters in @@ -597,9 +597,9 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id log#ldebug (lazy ("compute_fixed_point:" ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter ctx + ^ eval_ctx_to_string_no_filter meta ctx ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter ctx1 + ^ eval_ctx_to_string_no_filter meta ctx1 ^ "\n\n")); (* Check if we reached a fixed point: if not, iterate *) @@ -612,7 +612,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (lazy ("compute_fixed_point: fixed point computed before matching with input \ region groups:" ^ "\n\n- fp:\n" - ^ eval_ctx_to_string_no_filter fp + ^ eval_ctx_to_string_no_filter meta fp ^ "\n\n")); (* Make sure we have exactly one loop abstraction per function region (merge @@ -699,7 +699,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id abs.kind = SynthInput rg_id) meta "TODO : error message "; (* End this abstraction *) let ctx = - InterpreterBorrows.end_abstraction_no_synth config abs_id ctx + InterpreterBorrows.end_abstraction_no_synth meta config abs_id ctx in (* Explore the context, and check which abstractions are not there anymore *) let ids, _ = compute_ctx_ids ctx in @@ -725,7 +725,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (* We also check that all the regions need to end - this is not necessary per se, but if it doesn't happen it is bizarre and worth investigating... *) - cassert (AbstractionId.Set.equal !aids_union !fp_aids) meta "Not all regions need to end TODO"; + cassert (AbstractionId.Set.equal !aids_union !fp_aids) meta "Not all regions need to end TODO: Error message"; (* Merge the abstractions which need to be merged, and compute the map from region id to abstraction id *) @@ -777,7 +777,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id ^ AbstractionId.to_string !id0)); (* Note that we merge *into* [id0] *) let fp', id0' = - merge_into_abstraction loop_id abs_kind false !fp id !id0 + merge_into_abstraction meta loop_id abs_kind false !fp id !id0 in fp := fp'; id0 := id0'; @@ -793,7 +793,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (* Reorder the loans and borrows in the fresh abstractions in the fixed-point *) let fp = - reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (Option.get !fixed_ids).aids !fp + reorder_loans_borrows_in_fresh_abs meta (Option.get !fixed_ids).aids !fp in (* Update the abstraction's [can_end] field and their kinds. @@ -838,7 +838,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (lazy ("compute_fixed_point: fixed point after matching with the function \ region groups:\n" - ^ eval_ctx_to_string_no_filter fp_test)); + ^ eval_ctx_to_string_no_filter meta fp_test)); compute_fixed_point fp_test 1 1 in @@ -855,21 +855,21 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se log#ldebug (lazy ("compute_fixed_point_id_correspondance:\n\n- fixed_ids:\n" - ^ show_ids_sets fixed_ids ^ "\n\n- src_ctx:\n" ^ eval_ctx_to_string src_ctx - ^ "\n\n- tgt_ctx:\n" ^ eval_ctx_to_string tgt_ctx ^ "\n\n")); + ^ show_ids_sets fixed_ids ^ "\n\n- src_ctx:\n" ^ eval_ctx_to_string meta src_ctx + ^ "\n\n- tgt_ctx:\n" ^ eval_ctx_to_string meta tgt_ctx ^ "\n\n")); - let filt_src_env, _, _ = ctx_split_fixed_new fixed_ids src_ctx in + let filt_src_env, _, _ = ctx_split_fixed_new meta fixed_ids src_ctx in let filt_src_ctx = { src_ctx with env = filt_src_env } in - let filt_tgt_env, new_absl, _ = ctx_split_fixed_new fixed_ids tgt_ctx in + let filt_tgt_env, new_absl, _ = ctx_split_fixed_new meta fixed_ids tgt_ctx in let filt_tgt_ctx = { tgt_ctx with env = filt_tgt_env } in log#ldebug (lazy ("compute_fixed_point_id_correspondance:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- filt_src_ctx:\n" - ^ eval_ctx_to_string filt_src_ctx + ^ eval_ctx_to_string meta filt_src_ctx ^ "\n\n- filt_tgt_ctx:\n" - ^ eval_ctx_to_string filt_tgt_ctx + ^ eval_ctx_to_string meta filt_tgt_ctx ^ "\n\n")); (* Match the source context and the filtered target context *) @@ -886,7 +886,7 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in let lookup_in_src id = lookup_shared_loan id src_ctx in Option.get - (match_ctxs check_equiv fixed_ids lookup_in_tgt lookup_in_src filt_tgt_ctx + (match_ctxs meta check_equiv fixed_ids lookup_in_tgt lookup_in_src filt_tgt_ctx filt_src_ctx) in @@ -1089,9 +1089,9 @@ let compute_fp_ctx_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) (fp_ctx : log#ldebug (lazy ("compute_fp_ctx_symbolic_values:" ^ "\n- src context:\n" - ^ eval_ctx_to_string_no_filter ctx + ^ eval_ctx_to_string_no_filter meta ctx ^ "\n- fixed point:\n" - ^ eval_ctx_to_string_no_filter fp_ctx + ^ eval_ctx_to_string_no_filter meta fp_ctx ^ "\n- fresh_sids: " ^ SymbolicValueId.Set.show fresh_sids ^ "\n- input_svalues: " diff --git a/compiler/InterpreterLoopsFixedPoint.mli b/compiler/InterpreterLoopsFixedPoint.mli index 7c3f6199..d727e9bd 100644 --- a/compiler/InterpreterLoopsFixedPoint.mli +++ b/compiler/InterpreterLoopsFixedPoint.mli @@ -60,7 +60,7 @@ val cleanup_fresh_values_and_abs : config -> ids_sets -> Cps.cm_fun we only introduce a fresh abstraction for [l1]. *) -val prepare_ashared_loans : loop_id option -> Cps.cm_fun +val prepare_ashared_loans : Meta.meta -> loop_id option -> Cps.cm_fun (** Compute a fixed-point for the context at the entry of the loop. We also return: @@ -77,6 +77,7 @@ val prepare_ashared_loans : loop_id option -> Cps.cm_fun the values which are read or modified (some symbolic values may be ignored). *) val compute_loop_entry_fixed_point : + Meta.meta -> config -> loop_id -> Cps.st_cm_fun -> @@ -160,7 +161,7 @@ val compute_loop_entry_fixed_point : through the loan [l1] is actually the value which has to be given back to [l0]. *) val compute_fixed_point_id_correspondance : - ids_sets -> eval_ctx -> eval_ctx -> borrow_loan_corresp + Meta.meta -> ids_sets -> eval_ctx -> eval_ctx -> borrow_loan_corresp (** Compute the set of "quantified" symbolic value ids in a fixed-point context. @@ -169,4 +170,4 @@ val compute_fixed_point_id_correspondance : - the list of input symbolic values *) val compute_fp_ctx_symbolic_values : - eval_ctx -> eval_ctx -> symbolic_value_id_set * symbolic_value list + Meta.meta -> eval_ctx -> eval_ctx -> symbolic_value_id_set * symbolic_value list diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index fc2a97e5..ef4807e4 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -136,7 +136,7 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids - ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n")); + ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string meta ctx0 ^ "\n\n")); let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in @@ -160,7 +160,7 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) | EBinding (BDummy id, v) -> if is_fresh_did id then let absl = - convert_value_to_abstractions abs_kind can_end + convert_value_to_abstractions meta abs_kind can_end destructure_shared_values ctx0 v in List.map (fun abs -> EAbs abs) absl @@ -171,19 +171,19 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx: after converting values to abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n\n" + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string meta ctx ^ "\n\n" )); log#ldebug (lazy ("collapse_ctx: after decomposing the shared values in the abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n\n" + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string meta ctx ^ "\n\n" )); (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in let ids_maps = - compute_abs_borrows_loans_maps (merge_funs = None) explore env + compute_abs_borrows_loans_maps meta (merge_funs = None) explore env in let { abs_ids; @@ -252,12 +252,12 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) ^ AbstractionId.to_string abs_id1 ^ " into " ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" ^ eval_ctx_to_string !ctx)); + ^ ":\n\n" ^ eval_ctx_to_string meta !ctx)); (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = - merge_into_abstraction abs_kind can_end merge_funs !ctx + merge_into_abstraction meta abs_kind can_end merge_funs !ctx abs_id1 abs_id0 in ctx := nctx; @@ -272,7 +272,7 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids - ^ "\n\n- after collapse:\n" ^ eval_ctx_to_string !ctx ^ "\n\n")); + ^ "\n\n- after collapse:\n" ^ eval_ctx_to_string meta !ctx ^ "\n\n")); (* Reorder the loans and borrows in the fresh abstractions *) let ctx = reorder_loans_borrows_in_fresh_abs meta old_ids.aids !ctx in @@ -281,7 +281,7 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- after collapse and reorder borrows/loans:\n" - ^ eval_ctx_to_string ctx ^ "\n\n")); + ^ eval_ctx_to_string meta ctx ^ "\n\n")); (* Return the new context *) ctx @@ -360,7 +360,7 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id cassert (not (value_has_loans_or_borrows ctx sv1.value)) meta ""; let ty = ty0 in let child = child0 in - let sv = M.match_typed_values ctx ctx sv0 sv1 in + let sv = M.match_typed_values meta ctx ctx sv0 sv1 in let value = ALoan (ASharedLoan (ids, sv, child)) in { value; ty } in @@ -375,7 +375,7 @@ let merge_into_abstraction (meta : Meta.meta) (loop_id : LoopId.id) (abs_kind : (can_end : bool) (ctx : eval_ctx) (aid0 : AbstractionId.id) (aid1 : AbstractionId.id) : eval_ctx * AbstractionId.id = let merge_funs = mk_collapse_ctx_merge_duplicate_funs meta loop_id ctx in - merge_into_abstraction abs_kind can_end (Some merge_funs) ctx aid0 aid1 + merge_into_abstraction meta abs_kind can_end (Some merge_funs) ctx aid0 aid1 (** Collapse an environment, merging the duplicated borrows/loans. @@ -397,9 +397,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (lazy ("join_ctxs:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter ctx0 + ^ eval_ctx_to_string_no_filter meta ctx0 ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter ctx1 + ^ eval_ctx_to_string_no_filter meta ctx1 ^ "\n\n")); let env0 = List.rev ctx0.env in @@ -413,9 +413,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (lazy ("join_suffixes:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter { ctx0 with env = List.rev env0 } + ^ eval_ctx_to_string_no_filter meta { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter { ctx1 with env = List.rev env1 } + ^ eval_ctx_to_string_no_filter meta { ctx1 with env = List.rev env1 } ^ "\n\n")); (* Sanity check: there are no values/abstractions which should be in the prefix *) @@ -456,9 +456,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (lazy ("join_prefixes: BDummys:\n\n- fixed_ids:\n" ^ "\n" ^ show_ids_sets fixed_ids ^ "\n\n- value0:\n" - ^ env_elem_to_string ctx0 var0 + ^ env_elem_to_string meta ctx0 var0 ^ "\n\n- value1:\n" - ^ env_elem_to_string ctx1 var1 + ^ env_elem_to_string meta ctx1 var1 ^ "\n\n")); (* Two cases: the dummy value is an old value, in which case the bindings @@ -468,7 +468,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (* Still in the prefix: match the values *) cassert (b0 = b1) meta "Bindings are not the same. We are not in the prefix anymore"; let b = b0 in - let v = M.match_typed_values ctx0 ctx1 v0 v1 in + let v = M.match_typed_values meta ctx0 ctx1 v0 v1 in let var = EBinding (BDummy b, v) in (* Continue *) var :: join_prefixes env0' env1') @@ -481,9 +481,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (lazy ("join_prefixes: BVars:\n\n- fixed_ids:\n" ^ "\n" ^ show_ids_sets fixed_ids ^ "\n\n- value0:\n" - ^ env_elem_to_string ctx0 var0 + ^ env_elem_to_string meta ctx0 var0 ^ "\n\n- value1:\n" - ^ env_elem_to_string ctx1 var1 + ^ env_elem_to_string meta ctx1 var1 ^ "\n\n")); (* Variable bindings *must* be in the prefix and consequently their @@ -492,7 +492,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c ids must be the same"; (* Match the values *) let b = b0 in - let v = M.match_typed_values ctx0 ctx1 v0 v1 in + let v = M.match_typed_values meta ctx0 ctx1 v0 v1 in let var = EBinding (BVar b, v) in (* Continue *) var :: join_prefixes env0' env1' @@ -501,8 +501,8 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c log#ldebug (lazy ("join_prefixes: Abs:\n\n- fixed_ids:\n" ^ "\n" - ^ show_ids_sets fixed_ids ^ "\n\n- abs0:\n" ^ abs_to_string ctx0 abs0 - ^ "\n\n- abs1:\n" ^ abs_to_string ctx1 abs1 ^ "\n\n")); + ^ show_ids_sets fixed_ids ^ "\n\n- abs0:\n" ^ abs_to_string meta ctx0 abs0 + ^ "\n\n- abs1:\n" ^ abs_to_string meta ctx1 abs1 ^ "\n\n")); (* Same as for the dummy values: there are two cases *) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( @@ -584,7 +584,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c with ValueMatchFailure e -> Error e (** Destructure all the new abstractions *) -let destructure_new_abs (loop_id : LoopId.id) +let destructure_new_abs (meta : Meta.meta) (loop_id : LoopId.id) (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in @@ -597,7 +597,7 @@ let destructure_new_abs (loop_id : LoopId.id) (fun abs -> if is_fresh_abs_id abs.abs_id then let abs = - destructure_abs abs_kind can_end destructure_shared_values ctx abs + destructure_abs meta abs_kind can_end destructure_shared_values ctx abs in abs else abs) @@ -657,9 +657,9 @@ let loop_join_origin_with_continue_ctxs (meta : Meta.meta) (config : config) (lo let ctx = match err with | LoanInRight bid -> - InterpreterBorrows.end_borrow_no_synth config bid ctx + InterpreterBorrows.end_borrow_no_synth meta config bid ctx | LoansInRight bids -> - InterpreterBorrows.end_borrows_no_synth config bids ctx + InterpreterBorrows.end_borrows_no_synth meta config bids ctx | AbsInRight _ | AbsInLeft _ | LoanInLeft _ | LoansInLeft _ -> craise meta "Unexpected" in @@ -669,21 +669,21 @@ let loop_join_origin_with_continue_ctxs (meta : Meta.meta) (config : config) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: initial ctx:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx)); (* Destructure the abstractions introduced in the new context *) - let ctx = destructure_new_abs loop_id fixed_ids.aids ctx in + let ctx = destructure_new_abs meta loop_id fixed_ids.aids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after destructure:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx)); (* Collapse the context we want to add to the join *) let ctx = collapse_ctx meta loop_id None fixed_ids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after collapse:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx)); (* Refresh the fresh abstractions *) let ctx = refresh_abs fixed_ids.aids ctx in @@ -693,7 +693,7 @@ let loop_join_origin_with_continue_ctxs (meta : Meta.meta) (config : config) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after join:\n" - ^ eval_ctx_to_string ctx1)); + ^ eval_ctx_to_string meta ctx1)); (* Collapse again - the join might have introduce abstractions we want to merge with the others (note that those abstractions may actually @@ -702,7 +702,7 @@ let loop_join_origin_with_continue_ctxs (meta : Meta.meta) (config : config) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after join-collapse:\n" - ^ eval_ctx_to_string !joined_ctx)); + ^ eval_ctx_to_string meta !joined_ctx)); (* Sanity check *) if !Config.sanity_checks then Invariants.check_invariants meta !joined_ctx; diff --git a/compiler/InterpreterLoopsJoinCtxs.mli b/compiler/InterpreterLoopsJoinCtxs.mli index bb9f14ed..e79e6a25 100644 --- a/compiler/InterpreterLoopsJoinCtxs.mli +++ b/compiler/InterpreterLoopsJoinCtxs.mli @@ -16,6 +16,7 @@ open InterpreterLoopsCore - [aid1] *) val merge_into_abstraction : + Meta.meta -> loop_id -> abs_kind -> bool -> @@ -84,7 +85,7 @@ val merge_into_abstraction : - [ctx0] - [ctx1] *) -val join_ctxs : loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update +val join_ctxs : Meta.meta -> loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update (** Join the context at the entry of the loop with the contexts upon reentry (upon reaching the [Continue] statement - the goal is to compute a fixed @@ -103,6 +104,7 @@ val join_ctxs : loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update - [ctxl] *) val loop_join_origin_with_continue_ctxs : + Meta.meta -> config -> loop_id -> ids_sets -> diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 67c1155c..08d18407 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -20,7 +20,7 @@ module S = SynthesizeSymbolic (** The local logger *) let log = Logging.loops_match_ctxs_log -let compute_abs_borrows_loans_maps (no_duplicates : bool) +let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) (explore : abs -> bool) (env : env) : abs_borrows_loans_maps = let abs_ids = ref [] in let abs_to_borrows = ref AbstractionId.Map.empty in @@ -94,7 +94,7 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) | AIgnoredSharedLoan child -> (* Ignore the id of the loan, if there is *) self#visit_typed_avalue abs_id child - | AEndedMutLoan _ | AEndedSharedLoan _ -> raise (Failure "Unreachable") + | AEndedMutLoan _ | AEndedSharedLoan _ -> craise meta "Unreachable" (** Make sure we don't register the ignored ids *) method! visit_aborrow_content abs_id bc = @@ -108,7 +108,7 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) (* Ignore the id of the borrow, if there is *) self#visit_typed_avalue abs_id child | AEndedMutBorrow _ | AEndedSharedBorrow -> - raise (Failure "Unreachable") + craise meta "Unreachable" method! visit_borrow_id abs_id bid = register_borrow_id abs_id bid method! visit_loan_id abs_id lid = register_loan_id abs_id lid @@ -184,9 +184,9 @@ let rec match_types (match_distinct_types : ty -> ty -> ty) | _ -> match_distinct_types ty0 ty1 module MakeMatcher (M : PrimMatcher) : Matcher = struct - let rec match_typed_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let rec match_typed_values (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (v0 : typed_value) (v1 : typed_value) : typed_value = - let match_rec = match_typed_values ctx0 ctx1 in + let match_rec = match_typed_values meta ctx0 ctx1 in let ty = M.match_etys ctx0 ctx1 v0.ty v1.ty in (* Using ValuesUtils.value_has_borrows on purpose here: we want to make explicit the fact that, though we have to pick @@ -197,7 +197,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct in match (v0.value, v1.value) with | VLiteral lv0, VLiteral lv1 -> - if lv0 = lv1 then v1 else M.match_distinct_literals ctx0 ctx1 ty lv0 lv1 + if lv0 = lv1 then v1 else M.match_distinct_literals meta ctx0 ctx1 ty lv0 lv1 | VAdt av0, VAdt av1 -> if av0.variant_id = av1.variant_id then let fields = List.combine av0.field_values av1.field_values in @@ -213,14 +213,14 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct assert (not (value_has_borrows v0.value)); assert (not (value_has_borrows v1.value)); (* Merge *) - M.match_distinct_adts ctx0 ctx1 ty av0 av1) + M.match_distinct_adts meta ctx0 ctx1 ty av0 av1) | VBottom, VBottom -> v0 | VBorrow bc0, VBorrow bc1 -> let bc = match (bc0, bc1) with | VSharedBorrow bid0, VSharedBorrow bid1 -> let bid = - M.match_shared_borrows ctx0 ctx1 match_rec ty bid0 bid1 + M.match_shared_borrows meta ctx0 ctx1 match_rec ty bid0 bid1 in VSharedBorrow bid | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> @@ -231,7 +231,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)); let bid, bv = - M.match_mut_borrows ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv + M.match_mut_borrows meta ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv in VMutBorrow (bid, bv) | VReservedMutBorrow _, _ @@ -242,7 +242,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct trying to match a reserved borrow, which shouldn't happen because reserved borrow should be eliminated very quickly - they are introduced just before function calls which activate them *) - raise (Failure "Unexpected") + craise meta "Unexpected" in { value = VBorrow bc; ty } | VLoan lc0, VLoan lc1 -> @@ -259,7 +259,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let id = M.match_mut_loans ctx0 ctx1 ty id0 id1 in VMutLoan id | VSharedLoan _, VMutLoan _ | VMutLoan _, VSharedLoan _ -> - raise (Failure "Unreachable") + craise meta "Unreachable" in { value = VLoan lc; ty = v1.ty } | VSymbolic sv0, VSymbolic sv1 -> @@ -268,7 +268,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct assert (not (value_has_borrows v0.value)); assert (not (value_has_borrows v1.value)); (* Match *) - let sv = M.match_symbolic_values ctx0 ctx1 sv0 sv1 in + let sv = M.match_symbolic_values meta ctx0 ctx1 sv0 sv1 in { v1 with value = VSymbolic sv } | VLoan lc, _ -> ( match lc with @@ -278,27 +278,27 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match lc with | VSharedLoan (ids, _) -> raise (ValueMatchFailure (LoansInRight ids)) | VMutLoan id -> raise (ValueMatchFailure (LoanInRight id))) - | VSymbolic sv, _ -> M.match_symbolic_with_other ctx0 ctx1 true sv v1 - | _, VSymbolic sv -> M.match_symbolic_with_other ctx0 ctx1 false sv v0 - | VBottom, _ -> M.match_bottom_with_other ctx0 ctx1 true v1 - | _, VBottom -> M.match_bottom_with_other ctx0 ctx1 false v0 + | VSymbolic sv, _ -> M.match_symbolic_with_other meta ctx0 ctx1 true sv v1 + | _, VSymbolic sv -> M.match_symbolic_with_other meta ctx0 ctx1 false sv v0 + | VBottom, _ -> M.match_bottom_with_other meta ctx0 ctx1 true v1 + | _, VBottom -> M.match_bottom_with_other meta ctx0 ctx1 false v0 | _ -> log#ldebug (lazy ("Unexpected match case:\n- value0: " - ^ typed_value_to_string ctx0 v0 + ^ typed_value_to_string meta ctx0 v0 ^ "\n- value1: " - ^ typed_value_to_string ctx1 v1)); - raise (Failure "Unexpected match case") + ^ typed_value_to_string meta ctx1 v1)); + craise meta "Unexpected match case" - and match_typed_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) + and match_typed_avalues (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (v0 : typed_avalue) (v1 : typed_avalue) : typed_avalue = log#ldebug (lazy ("match_typed_avalues:\n- value0: " - ^ typed_avalue_to_string ctx0 v0 + ^ typed_avalue_to_string meta ctx0 v0 ^ "\n- value1: " - ^ typed_avalue_to_string ctx1 v1)); + ^ typed_avalue_to_string meta ctx1 v1)); (* Using ValuesUtils.value_has_borrows on purpose here: we want to make explicit the fact that, though we have to pick @@ -308,8 +308,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos in - let match_rec = match_typed_values ctx0 ctx1 in - let match_arec = match_typed_avalues ctx0 ctx1 in + let match_rec = match_typed_values meta ctx0 ctx1 in + let match_arec = match_typed_avalues meta ctx0 ctx1 in let ty = M.match_rtys ctx0 ctx1 v0.ty v1.ty in match (v0.value, v1.value) with | AAdt av0, AAdt av1 -> @@ -323,15 +323,15 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct in { value; ty } else (* Merge *) - M.match_distinct_aadts ctx0 ctx1 v0.ty av0 v1.ty av1 ty - | ABottom, ABottom -> mk_abottom ty - | AIgnored, AIgnored -> mk_aignored ty + M.match_distinct_aadts meta ctx0 ctx1 v0.ty av0 v1.ty av1 ty + | ABottom, ABottom -> mk_abottom meta ty + | AIgnored, AIgnored -> mk_aignored meta ty | ABorrow bc0, ABorrow bc1 -> ( log#ldebug (lazy "match_typed_avalues: borrows"); match (bc0, bc1) with | ASharedBorrow bid0, ASharedBorrow bid1 -> log#ldebug (lazy "match_typed_avalues: shared borrows"); - M.match_ashared_borrows ctx0 ctx1 v0.ty bid0 v1.ty bid1 ty + M.match_ashared_borrows meta ctx0 ctx1 v0.ty bid0 v1.ty bid1 ty | AMutBorrow (bid0, av0), AMutBorrow (bid1, av1) -> log#ldebug (lazy "match_typed_avalues: mut borrows"); log#ldebug @@ -340,10 +340,10 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut borrows: matched children values"); - M.match_amut_borrows ctx0 ctx1 v0.ty bid0 av0 v1.ty bid1 av1 ty av + M.match_amut_borrows meta ctx0 ctx1 v0.ty bid0 av0 v1.ty bid1 av1 ty av | AIgnoredMutBorrow _, AIgnoredMutBorrow _ -> (* The abstractions are destructured: we shouldn't get there *) - raise (Failure "Unexpected") + craise meta "Unexpected" | AProjSharedBorrow asb0, AProjSharedBorrow asb1 -> ( match (asb0, asb1) with | [], [] -> @@ -352,7 +352,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct v0 | _ -> (* We should get there only if there are nested borrows *) - raise (Failure "Unexpected")) + craise meta "Unexpected") | _ -> (* TODO: getting there is not necessarily inconsistent (it may just be because the environments don't match) so we may want @@ -363,7 +363,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct we are *currently* ending it, in which case we need to completely end it before continuing. *) - raise (Failure "Unexpected")) + craise meta "Unexpected") | ALoan lc0, ALoan lc1 -> ( log#ldebug (lazy "match_typed_avalues: loans"); (* TODO: maybe we should enforce that the ids are always exactly the same - @@ -374,7 +374,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in assert (not (value_has_borrows sv.value)); - M.match_ashared_loans ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 + M.match_ashared_loans meta ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 av1 ty sv av | AMutLoan (id0, av0), AMutLoan (id1, av1) -> log#ldebug (lazy "match_typed_avalues: mut loans"); @@ -383,18 +383,18 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut loans: matched children values"); - M.match_amut_loans ctx0 ctx1 v0.ty id0 av0 v1.ty id1 av1 ty av + M.match_amut_loans meta ctx0 ctx1 v0.ty id0 av0 v1.ty id1 av1 ty av | AIgnoredMutLoan _, AIgnoredMutLoan _ | AIgnoredSharedLoan _, AIgnoredSharedLoan _ -> (* Those should have been filtered when destructuring the abstractions - they are necessary only when there are nested borrows *) - raise (Failure "Unreachable") - | _ -> raise (Failure "Unreachable")) + craise meta "Unreachable" + | _ -> craise meta "Unreachable") | ASymbolic _, ASymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - raise (Failure "Unreachable") - | _ -> M.match_avalues ctx0 ctx1 v0 v1 + craise meta "Unreachable" + | _ -> M.match_avalues meta ctx0 ctx1 v0 v1 end module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct @@ -413,11 +413,11 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct assert (ty0 = ty1); ty0 - let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = - mk_fresh_symbolic_typed_value_from_no_regions_ty ty + mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_distinct_adts (ctx0 : eval_ctx) (ctx1 : eval_ctx) (ty : ety) + let match_distinct_adts (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (ty : ety) (adt0 : adt_value) (adt1 : adt_value) : typed_value = (* Check that the ADTs don't contain borrows - this is redundant with checks performed by the caller, but we prefer to be safe with regards to future @@ -447,12 +447,12 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct if bottom_in_adt_value ctx0.ended_regions adt0 || bottom_in_adt_value ctx1.ended_regions adt1 - then mk_bottom ty + then mk_bottom meta ty else (* No borrows, no loans, no bottoms: we can introduce a symbolic value *) - mk_fresh_symbolic_typed_value_from_no_regions_ty ty + mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) match_rec + let match_shared_borrows (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) match_rec (ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = (* Lookup the shared values and match them - we do this mostly to make sure we end loans which might appear on one side @@ -483,7 +483,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let borrows = [ mk_aborrow bid0; mk_aborrow bid1 ] in let loan = - ASharedLoan (BorrowId.Set.singleton bid2, sv, mk_aignored bv_ty) + ASharedLoan (BorrowId.Set.singleton bid2, sv, mk_aignored meta bv_ty) in (* Note that an aloan has a borrow type *) let loan : typed_avalue = { value = ALoan loan; ty = borrow_ty } in @@ -508,7 +508,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) bid2 - let match_mut_borrows (ctx0 : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_mut_borrows (meta : Meta.meta) (ctx0 : eval_ctx) (_ : eval_ctx) (ty : ety) (bid0 : borrow_id) (bv0 : typed_value) (bid1 : borrow_id) (bv1 : typed_value) (bv : typed_value) : borrow_id * typed_value = if bid0 = bid1 then ( @@ -576,14 +576,14 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let borrow_av = let ty = borrow_ty in - let value = ABorrow (AMutBorrow (bid0, mk_aignored bv_ty)) in - mk_typed_avalue ty value + let value = ABorrow (AMutBorrow (bid0, mk_aignored meta bv_ty)) in + mk_typed_avalue meta ty value in let loan_av = let ty = borrow_ty in - let value = ALoan (AMutLoan (nbid, mk_aignored bv_ty)) in - mk_typed_avalue ty value + let value = ALoan (AMutLoan (nbid, mk_aignored meta bv_ty)) in + mk_typed_avalue meta ty value in let avalues = [ borrow_av; loan_av ] in @@ -617,7 +617,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate a fresh symbolic value for the borrowed value *) let _, bv_ty, kind = ty_as_ref ty in - let sv = mk_fresh_symbolic_typed_value_from_no_regions_ty bv_ty in + let sv = mk_fresh_symbolic_typed_value_from_no_regions_ty meta bv_ty in let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in @@ -625,12 +625,12 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = let bv_ty = bv.ty in assert (ty_no_regions bv_ty); - let value = ABorrow (AMutBorrow (bid, mk_aignored bv_ty)) in + let value = ABorrow (AMutBorrow (bid, mk_aignored meta bv_ty)) in { value; ty = borrow_ty } in let borrows = [ mk_aborrow bid0 bv0; mk_aborrow bid1 bv1 ] in - let loan = AMutLoan (bid2, mk_aignored bv_ty) in + let loan = AMutLoan (bid2, mk_aignored meta bv_ty) in (* Note that an aloan has a borrow type *) let loan : typed_avalue = { value = ALoan loan; ty = borrow_ty } in @@ -685,7 +685,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct both borrows *) raise (ValueMatchFailure (LoanInLeft id0)) - let match_symbolic_values (ctx0 : eval_ctx) (_ : eval_ctx) + let match_symbolic_values (meta : Meta.meta) (ctx0 : eval_ctx) (_ : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -699,9 +699,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct borrows *) assert (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)); (* We simply introduce a fresh symbolic value *) - mk_fresh_symbolic_value sv0.sv_ty) + mk_fresh_symbolic_value meta sv0.sv_ty) - let match_symbolic_with_other (ctx0 : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (meta : Meta.meta) (ctx0 : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = (* Check that: - there are no borrows in the symbolic value @@ -721,9 +721,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct if value_is_left then raise (ValueMatchFailure (LoanInLeft id)) else raise (ValueMatchFailure (LoanInRight id))); (* Return a fresh symbolic value *) - mk_fresh_symbolic_typed_value sv.sv_ty + mk_fresh_symbolic_typed_value meta sv.sv_ty - let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) + let match_bottom_with_other (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) (v : typed_value) : typed_value = (* If there are outer loans in the non-bottom value, raise an exception. Otherwise, convert it to an abstraction and return [Bottom]. @@ -736,7 +736,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct with | Some (BorrowContent _) -> (* Can't get there: we only ask for outer *loans* *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Some (LoanContent lc) -> ( match lc with | VSharedLoan (ids, _) -> @@ -754,25 +754,25 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let destructure_shared_values = true in let ctx = if value_is_left then ctx0 else ctx1 in let absl = - convert_value_to_abstractions abs_kind can_end + convert_value_to_abstractions meta abs_kind can_end destructure_shared_values ctx v in push_absl absl; (* Return [Bottom] *) - mk_bottom v.ty + mk_bottom meta v.ty (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) - let match_distinct_aadts _ _ _ _ _ _ _ = raise (Failure "Unreachable") - let match_ashared_borrows _ _ _ _ _ _ = raise (Failure "Unreachable") - let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = raise (Failure "Unreachable") + let match_distinct_aadts (meta : Meta.meta) _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_ashared_borrows (meta : Meta.meta) _ _ _ _ _ _ = craise meta "Unreachable" + let match_amut_borrows (meta : Meta.meta) _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = - raise (Failure "Unreachable") + let match_ashared_loans (meta: Meta.meta) _ _ _ _ _ _ _ _ _ _ _ _ _ = + craise meta "Unreachable" - let match_amut_loans _ _ _ _ _ _ _ _ _ _ = raise (Failure "Unreachable") - let match_avalues _ _ _ _ = raise (Failure "Unreachable") + let match_amut_loans (meta: Meta.meta) _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_avalues (meta: Meta.meta) _ _ _ _ = craise meta "Unreachable" end (* Very annoying: functors only take modules as inputs... *) @@ -814,22 +814,22 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct assert (ty0 = ty1); ty0 - let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (l : literal) : typed_value = { value = VLiteral l; ty } - let match_distinct_adts (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_adts (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : adt_value) (adt1 : adt_value) : typed_value = (* Note that if there was a bottom inside the ADT on the left, the value on the left should have been simplified to bottom. *) { ty; value = VAdt adt1 } - let match_shared_borrows (_ : eval_ctx) (_ : eval_ctx) _ (_ : ety) + let match_shared_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) _ (_ : ety) (_ : borrow_id) (bid1 : borrow_id) : borrow_id = (* There can't be bottoms in shared values *) bid1 - let match_mut_borrows (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (_ : borrow_id) + let match_mut_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (_ : borrow_id) (_ : typed_value) (bid1 : borrow_id) (bv1 : typed_value) (_ : typed_value) : borrow_id * typed_value = (* There can't be bottoms in borrowed values *) @@ -845,15 +845,15 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (id1 : loan_id) : loan_id = id1 - let match_symbolic_values (_ : eval_ctx) (_ : eval_ctx) (_ : symbolic_value) + let match_symbolic_values (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : symbolic_value) (sv1 : symbolic_value) : symbolic_value = sv1 - let match_symbolic_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = if left then v else mk_typed_value_from_symbolic_value sv - let match_bottom_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_bottom_with_other (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (left : bool) (v : typed_value) : typed_value = let with_borrows = false in if left then ( @@ -865,35 +865,35 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct with | Some (BorrowContent _) -> (* Can't get there: we only ask for outer *loans* *) - raise (Failure "Unreachable") + craise meta "Unreachable" | Some (LoanContent _) -> (* We should have ended all the outer loans *) - raise (Failure "Unexpected outer loan") + craise meta "Unexpected outer loan" | None -> (* Move the value - note that we shouldn't get there if we were not allowed to move the value in the first place. *) push_moved_value v; (* Return [Bottom] *) - mk_bottom v.ty) + mk_bottom meta v.ty) else (* If we get there it means the source environment (e.g., the fixed-point) has a non-bottom value, while the target environment (e.g., the environment we have when we reach the continue) has bottom: we shouldn't get there. *) - raise (Failure "Unreachable") + craise meta "Unreachable" (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) - let match_distinct_aadts _ _ _ _ _ _ _ = raise (Failure "Unreachable") - let match_ashared_borrows _ _ _ _ _ _ = raise (Failure "Unreachable") - let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = raise (Failure "Unreachable") + let match_distinct_aadts (meta : Meta.meta) _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_ashared_borrows (meta : Meta.meta) _ _ _ _ _ _ = craise meta "Unreachable" + let match_amut_borrows (meta : Meta.meta) _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = - raise (Failure "Unreachable") + let match_ashared_loans (meta : Meta.meta) _ _ _ _ _ _ _ _ _ _ _ _ _ = + craise meta "Unreachable" - let match_amut_loans _ _ _ _ _ _ _ _ _ _ = raise (Failure "Unreachable") - let match_avalues _ _ _ _ = raise (Failure "Unreachable") + let match_amut_loans (meta : Meta.meta) _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_avalues (meta : Meta.meta) _ _ _ _ = craise meta "Unreachable" end module MakeCheckEquivMatcher (S : MatchCheckEquivState) : CheckEquivMatcher = @@ -998,15 +998,15 @@ struct in match_types match_distinct_types match_regions ty0 ty1 - let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = - mk_fresh_symbolic_typed_value_from_no_regions_ty ty + mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_distinct_adts (_ : eval_ctx) (_ : eval_ctx) (_ty : ety) + let match_distinct_adts (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ty : ety) (_adt0 : adt_value) (_adt1 : adt_value) : typed_value = raise (Distinct "match_distinct_adts") - let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_shared_borrows (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (match_typed_values : typed_value -> typed_value -> typed_value) (_ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = log#ldebug @@ -1027,16 +1027,16 @@ struct (lazy ("MakeCheckEquivMatcher: match_shared_borrows: looked up values:" ^ "sv0: " - ^ typed_value_to_string ctx0 v0 + ^ typed_value_to_string meta ctx0 v0 ^ ", sv1: " - ^ typed_value_to_string ctx1 v1)); + ^ typed_value_to_string meta ctx1 v1)); let _ = match_typed_values v0 v1 in () in bid - let match_mut_borrows (_ : eval_ctx) (_ : eval_ctx) (_ty : ety) + let match_mut_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ty : ety) (bid0 : borrow_id) (_bv0 : typed_value) (bid1 : borrow_id) (_bv1 : typed_value) (bv : typed_value) : borrow_id * typed_value = let bid = match_borrow_id bid0 bid1 in @@ -1052,7 +1052,7 @@ struct (bid1 : loan_id) : loan_id = match_loan_id bid0 bid1 - let match_symbolic_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_symbolic_values (_ : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -1089,7 +1089,7 @@ struct we want *) sv0) - let match_symbolic_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( @@ -1103,7 +1103,7 @@ struct (* Return - the returned value is not used, so we can return whatever we want *) v) - let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) + let match_bottom_with_other (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) (v : typed_value) : typed_value = (* It can happen that some variables get initialized in some branches and not in some others, which causes problems when matching. *) @@ -1112,7 +1112,7 @@ struct a continue, where the fixed point contains some bottom values. *) let value_is_left = not left in let ctx = if value_is_left then ctx0 else ctx1 in - if left && not (value_has_loans_or_borrows ctx v.value) then mk_bottom v.ty + if left && not (value_has_loans_or_borrows ctx v.value) then mk_bottom meta v.ty else raise (Distinct @@ -1120,51 +1120,51 @@ struct ^ Print.bool_to_string left ^ "\n- value to match with bottom:\n" ^ show_typed_value v)) - let match_distinct_aadts _ _ _ _ _ _ _ = + let match_distinct_aadts _ _ _ _ _ _ _ _ = raise (Distinct "match_distinct_adts") - let match_ashared_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _ty1 bid1 ty + let match_ashared_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _ty1 bid1 ty = let bid = match_borrow_id bid0 bid1 in let value = ABorrow (ASharedBorrow bid) in { value; ty } - let match_amut_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _av0 _ty1 bid1 + let match_amut_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _av0 _ty1 bid1 _av1 ty av = let bid = match_borrow_id bid0 bid1 in let value = ABorrow (AMutBorrow (bid, av)) in { value; ty } - let match_ashared_loans (_ : eval_ctx) (_ : eval_ctx) _ty0 ids0 _v0 _av0 _ty1 + let match_ashared_loans (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) _ty0 ids0 _v0 _av0 _ty1 ids1 _v1 _av1 ty v av = let bids = match_loan_ids ids0 ids1 in let value = ALoan (ASharedLoan (bids, v, av)) in { value; ty } - let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 + let match_amut_loans (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 id1 _av1 ty av = log#ldebug (lazy ("MakeCheckEquivMatcher:match_amut_loans:" ^ "\n- id0: " ^ BorrowId.to_string id0 ^ "\n- id1: " ^ BorrowId.to_string id1 ^ "\n- ty: " ^ ty_to_string ctx0 ty ^ "\n- av: " - ^ typed_avalue_to_string ctx1 av)); + ^ typed_avalue_to_string meta ctx1 av)); let id = match_loan_id id0 id1 in let value = ALoan (AMutLoan (id, av)) in { value; ty } - let match_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = + let match_avalues (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = log#ldebug (lazy ("avalues don't match:\n- v0: " - ^ typed_avalue_to_string ctx0 v0 + ^ typed_avalue_to_string meta ctx0 v0 ^ "\n- v1: " - ^ typed_avalue_to_string ctx1 v1)); + ^ typed_avalue_to_string meta ctx1 v1)); raise (Distinct "match_avalues") end -let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) +let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) (lookup_shared_value_in_ctx0 : BorrowId.id -> typed_value) (lookup_shared_value_in_ctx1 : BorrowId.id -> typed_value) (ctx0 : eval_ctx) (ctx1 : eval_ctx) : ids_maps option = @@ -1172,9 +1172,9 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) (lazy ("match_ctxs:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter ctx0 + ^ eval_ctx_to_string_no_filter meta ctx0 ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter ctx1 + ^ eval_ctx_to_string_no_filter meta ctx1 ^ "\n\n")); (* Initialize the maps and instantiate the matcher *) @@ -1282,7 +1282,7 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) log#ldebug (lazy "match_abstractions: matching values"); let _ = List.map - (fun (v0, v1) -> M.match_typed_avalues ctx0 ctx1 v0 v1) + (fun (v0, v1) -> M.match_typed_avalues meta ctx0 ctx1 v0 v1) (List.combine avalues0 avalues1) in log#ldebug (lazy "match_abstractions: values matched OK"); @@ -1303,9 +1303,9 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) ^ "\n- aid_map: " ^ AbstractionId.InjSubst.show_t !aid_map ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter { ctx0 with env = List.rev env0 } + ^ eval_ctx_to_string_no_filter meta { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter { ctx1 with env = List.rev env1 } + ^ eval_ctx_to_string_no_filter meta { ctx1 with env = List.rev env1 } ^ "\n\n")); match (env0, env1) with @@ -1321,12 +1321,12 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) assert ((not S.check_equiv) || ids_are_fixed ids)); (* We still match the values - allows to compute mappings (which are the identity actually) *) - let _ = M.match_typed_values ctx0 ctx1 v0 v1 in + let _ = M.match_typed_values meta ctx0 ctx1 v0 v1 in match_envs env0' env1' | EBinding (BVar b0, v0) :: env0', EBinding (BVar b1, v1) :: env1' -> assert (b0 = b1); (* Match the values *) - let _ = M.match_typed_values ctx0 ctx1 v0 v1 in + let _ = M.match_typed_values meta ctx0 ctx1 v0 v1 in (* Continue *) match_envs env0' env1' | EAbs abs0 :: env0', EAbs abs1 :: env1' -> @@ -1366,7 +1366,7 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) let env0, env1 = match (env0, env1) with | EFrame :: env0, EFrame :: env1 -> (env0, env1) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in match_envs env0 env1; @@ -1382,23 +1382,16 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) } in Some maps - with - | Distinct msg -> - log#ldebug (lazy ("match_ctxs: distinct: " ^ msg ^ "\n")); - None - | ValueMatchFailure k -> - log#ldebug - (lazy - ("match_ctxs: distinct: ValueMatchFailure" ^ show_updt_env_kind k - ^ "\n")); - None + with Distinct msg -> + log#ldebug (lazy ("match_ctxs: distinct: " ^ msg)); + None -let ctxs_are_equivalent (fixed_ids : ids_sets) (ctx0 : eval_ctx) +let ctxs_are_equivalent (meta : Meta.meta) (fixed_ids : ids_sets) (ctx0 : eval_ctx) (ctx1 : eval_ctx) : bool = let check_equivalent = true in - let lookup_shared_value _ = raise (Failure "Unreachable") in + let lookup_shared_value _ = craise meta "Unreachable" in Option.is_some - (match_ctxs check_equivalent fixed_ids lookup_shared_value + (match_ctxs meta check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx0 ctx1) let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id : LoopId.id) @@ -1409,23 +1402,23 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id (lazy ("prepare_match_ctx_with_target:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- src_ctx: " - ^ eval_ctx_to_string src_ctx ^ "\n- tgt_ctx: " ^ eval_ctx_to_string tgt_ctx + ^ eval_ctx_to_string meta src_ctx ^ "\n- tgt_ctx: " ^ eval_ctx_to_string meta tgt_ctx )); (* End the loans which lead to mismatches when joining *) let rec cf_reorganize_join_tgt : cm_fun = fun cf tgt_ctx -> (* Collect fixed values in the source and target contexts: end the loans in the source context which don't appear in the target context *) - let filt_src_env, _, _ = ctx_split_fixed_new fixed_ids src_ctx in - let filt_tgt_env, _, _ = ctx_split_fixed_new fixed_ids tgt_ctx in + let filt_src_env, _, _ = ctx_split_fixed_new meta fixed_ids src_ctx in + let filt_tgt_env, _, _ = ctx_split_fixed_new meta fixed_ids tgt_ctx in log#ldebug (lazy ("cf_reorganize_join_tgt: match_ctx_with_target:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- filt_src_ctx: " - ^ env_to_string src_ctx filt_src_env + ^ env_to_string meta src_ctx filt_src_env ^ "\n- filt_tgt_ctx: " - ^ env_to_string tgt_ctx filt_tgt_env)); + ^ env_to_string meta tgt_ctx filt_tgt_env)); (* Remove the abstractions *) let filter (ee : env_elem) : bool = @@ -1450,13 +1443,13 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id match (var0, var1) with | EBinding (BDummy b0, v0), EBinding (BDummy b1, v1) -> assert (b0 = b1); - let _ = M.match_typed_values src_ctx tgt_ctx v0 v1 in + let _ = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in () | EBinding (BVar b0, v0), EBinding (BVar b1, v1) -> assert (b0 = b1); - let _ = M.match_typed_values src_ctx tgt_ctx v0 v1 in + let _ = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in () - | _ -> raise (Failure "Unexpected")) + | _ -> craise meta "Unexpected") (List.combine filt_src_env filt_tgt_env) in (* No exception was thrown: continue *) @@ -1465,9 +1458,9 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id ("cf_reorganize_join_tgt: done with borrows/loans:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- filt_src_ctx: " - ^ env_to_string src_ctx filt_src_env + ^ env_to_string meta src_ctx filt_src_env ^ "\n- filt_tgt_ctx: " - ^ env_to_string tgt_ctx filt_tgt_env)); + ^ env_to_string meta tgt_ctx filt_tgt_env)); (* We are done with the borrows/loans: now make sure we move all the values which are bottom in the src environment (i.e., the @@ -1487,13 +1480,13 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id match (var0, var1) with | EBinding (BDummy b0, v0), EBinding ((BDummy b1 as var1), v1) -> assert (b0 = b1); - let v = M.match_typed_values src_ctx tgt_ctx v0 v1 in + let v = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in (var1, v) | EBinding (BVar b0, v0), EBinding ((BVar b1 as var1), v1) -> assert (b0 = b1); - let v = M.match_typed_values src_ctx tgt_ctx v0 v1 in + let v = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in (var1, v) - | _ -> raise (Failure "Unexpected")) + | _ -> craise meta "Unexpected") (List.combine filt_src_env filt_tgt_env) in let var_to_new_val = BinderMap.of_list var_to_new_val in @@ -1521,18 +1514,18 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id (lazy ("cf_reorganize_join_tgt: done with borrows/loans and moves:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- src_ctx: " - ^ eval_ctx_to_string src_ctx ^ "\n- tgt_ctx: " - ^ eval_ctx_to_string tgt_ctx)); + ^ eval_ctx_to_string meta src_ctx ^ "\n- tgt_ctx: " + ^ eval_ctx_to_string meta tgt_ctx)); cf tgt_ctx with ValueMatchFailure e -> (* Exception: end the corresponding borrows, and continue *) let cc = match e with - | LoanInRight bid -> InterpreterBorrows.end_borrow config bid - | LoansInRight bids -> InterpreterBorrows.end_borrows config bids + | LoanInRight bid -> InterpreterBorrows.end_borrow meta config bid + | LoansInRight bids -> InterpreterBorrows.end_borrows meta config bids | AbsInRight _ | AbsInLeft _ | LoanInLeft _ | LoansInLeft _ -> - raise (Failure "Unexpected") + craise meta "Unexpected" in comp cc cf_reorganize_join_tgt cf tgt_ctx in @@ -1587,9 +1580,9 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) ^ eval_ctx_to_string src_ctx ^ "\n- tgt_ctx: " ^ eval_ctx_to_string tgt_ctx)); - let filt_tgt_env, _, _ = ctx_split_fixed_new fixed_ids tgt_ctx in + let filt_tgt_env, _, _ = ctx_split_fixed_new meta fixed_ids tgt_ctx in let filt_src_env, new_absl, new_dummyl = - ctx_split_fixed_new fixed_ids src_ctx + ctx_split_fixed_new meta fixed_ids src_ctx in assert (new_dummyl = []); let filt_tgt_ctx = { tgt_ctx with env = filt_tgt_env } in @@ -1603,13 +1596,13 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) match snd (lookup_loan meta ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in let lookup_in_src id = lookup_shared_loan id src_ctx in let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in (* Match *) Option.get - (match_ctxs check_equiv fixed_ids lookup_in_src lookup_in_tgt + (match_ctxs meta check_equiv fixed_ids lookup_in_src lookup_in_tgt filt_src_ctx filt_tgt_ctx) in let tgt_to_src_borrow_map = @@ -1623,13 +1616,13 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs:" ^ "\n\n- src_ctx: " - ^ eval_ctx_to_string src_ctx ^ "\n\n- tgt_ctx: " - ^ eval_ctx_to_string tgt_ctx ^ "\n\n- filt_tgt_ctx: " - ^ eval_ctx_to_string_no_filter filt_tgt_ctx + ^ eval_ctx_to_string meta src_ctx ^ "\n\n- tgt_ctx: " + ^ eval_ctx_to_string meta tgt_ctx ^ "\n\n- filt_tgt_ctx: " + ^ eval_ctx_to_string_no_filter meta filt_tgt_ctx ^ "\n\n- filt_src_ctx: " - ^ eval_ctx_to_string_no_filter filt_src_ctx + ^ eval_ctx_to_string_no_filter meta filt_src_ctx ^ "\n\n- new_absl:\n" - ^ eval_ctx_to_string + ^ eval_ctx_to_string meta { src_ctx with env = List.map (fun abs -> EAbs abs) new_absl } ^ "\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- fp_bl_maps:\n" ^ show_borrow_loan_corresp fp_bl_maps @@ -1828,18 +1821,17 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: done:\n\ - - result ctx:\n" ^ eval_ctx_to_string tgt_ctx)); + - result ctx:\n" ^ eval_ctx_to_string meta tgt_ctx)); (* Sanity check *) if !Config.sanity_checks then - Invariants.check_borrowed_values_invariant tgt_ctx; - + Invariants.check_borrowed_values_invariant meta tgt_ctx; (* End all the borrows which appear in the *new* abstractions *) let new_borrows = BorrowId.Set.of_list (List.map snd (BorrowId.Map.bindings !src_fresh_borrows_map)) in - let cc = InterpreterBorrows.end_borrows config new_borrows in + let cc = InterpreterBorrows.end_borrows meta config new_borrows in (* Compute the loop input values *) let input_values = diff --git a/compiler/InterpreterLoopsMatchCtxs.mli b/compiler/InterpreterLoopsMatchCtxs.mli index d6f89ed6..0db1ff1d 100644 --- a/compiler/InterpreterLoopsMatchCtxs.mli +++ b/compiler/InterpreterLoopsMatchCtxs.mli @@ -19,7 +19,7 @@ open InterpreterLoopsCore - [env] *) val compute_abs_borrows_loans_maps : - bool -> (abs -> bool) -> env -> abs_borrows_loans_maps + Meta.meta -> bool -> (abs -> bool) -> env -> abs_borrows_loans_maps (** Generic functor to implement matching functions between values, environments, etc. @@ -91,6 +91,7 @@ module MakeCheckEquivMatcher : functor (_ : MatchCheckEquivState) -> We return an optional ids map: [Some] if the match succeeded, [None] otherwise. *) val match_ctxs : + Meta.meta -> bool -> ids_sets -> (loan_id -> typed_value) -> @@ -135,7 +136,7 @@ val match_ctxs : - [ctx0] - [ctx1] *) -val ctxs_are_equivalent : ids_sets -> eval_ctx -> eval_ctx -> bool +val ctxs_are_equivalent : Meta.meta -> ids_sets -> eval_ctx -> eval_ctx -> bool (** Reorganize a target context so that we can match it with a source context (remember that the source context is generally the fixed point context, @@ -299,6 +300,7 @@ val prepare_match_ctx_with_target : - [src_ctx] *) val match_ctx_with_target : + Meta.meta -> config -> loop_id -> bool -> diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index cc1e3208..c6db7f2e 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -100,8 +100,8 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : (* Check consistency *) (match (proj_kind, type_id) with | ProjAdt (def_id, opt_variant_id), TAdtId def_id' -> - assert (def_id = def_id'); - assert (opt_variant_id = adt.variant_id) + cassert (def_id = def_id') meta "TODO: Error message"; + cassert (opt_variant_id = adt.variant_id) meta "TODO: Error message" | _ -> craise meta "Unreachable"); (* Actually project *) let fv = FieldId.nth adt.field_values field_id in @@ -117,7 +117,7 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : Ok (ctx, { res with updated })) (* Tuples *) | Field (ProjTuple arity, field_id), VAdt adt, TAdt (TTuple, _) -> ( - assert (arity = List.length adt.field_values); + cassert (arity = List.length adt.field_values) meta "TODO: Error message"; let fv = FieldId.nth adt.field_values field_id in (* Project *) match access_projection meta access ctx update p' fv with @@ -346,30 +346,30 @@ let write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : type | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) | Ok ctx -> ctx -let compute_expanded_bottom_adt_value (ctx : eval_ctx) (def_id : TypeDeclId.id) +let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) (generics : generic_args) : - typed_value = - assert (TypesUtils.generic_args_only_erased_regions generics); + typed_value = + cassert (TypesUtils.generic_args_only_erased_regions generics) meta "TODO: Error message"; (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) - let def = ctx_lookup_type_decl ctx def_id in - assert (List.length generics.regions = List.length def.generics.regions); + let def = ctx_lookup_type_decl ctx def_id in (*TODO: check if can be moved before assert ?*) + cassert (List.length generics.regions = List.length def.generics.regions) meta "TODO: Error message"; (* Compute the field types *) let field_types = AssociatedTypes.type_decl_get_inst_norm_field_etypes ctx def opt_variant_id generics in (* Initialize the expanded value *) - let fields = List.map mk_bottom field_types in + let fields = List.map (mk_bottom meta) field_types in let av = VAdt { variant_id = opt_variant_id; field_values = fields } in let ty = TAdt (TAdtId def_id, generics) in { value = av; ty } -let compute_expanded_bottom_tuple_value (field_types : ety list) : typed_value = +let compute_expanded_bottom_tuple_value (meta : Meta.meta) (field_types : ety list) : typed_value = (* Generate the field values *) - let fields = List.map mk_bottom field_types in + let fields = List.map (mk_bottom meta) field_types in let v = VAdt { variant_id = None; field_values = fields } in let generics = TypesUtils.mk_generic_args [] field_types [] [] in let ty = TAdt (TTuple, generics) in @@ -425,16 +425,16 @@ let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), TAdt (TAdtId def_id', generics) ) -> - assert (def_id = def_id'); - compute_expanded_bottom_adt_value ctx def_id opt_variant_id generics + cassert (def_id = def_id') meta "TODO: Error message"; + compute_expanded_bottom_adt_value meta ctx def_id opt_variant_id generics (* Tuples *) | ( Field (ProjTuple arity, _), TAdt (TTuple, { regions = []; types; const_generics = []; trait_refs = [] }) ) -> - assert (arity = List.length types); + cassert (arity = List.length types) meta "TODO: Error message"; (* Generate the field values *) - compute_expanded_bottom_tuple_value types + compute_expanded_bottom_tuple_value meta types | _ -> craise meta @@ -454,9 +454,9 @@ let rec update_ctx_along_read_place (meta : Meta.meta) (config : config) (access | Error err -> let cc = match err with - | FailSharedLoan bids -> end_borrows config bids - | FailMutLoan bid -> end_borrow config bid - | FailReservedMutBorrow bid -> promote_reserved_mut_borrow config bid + | FailSharedLoan bids -> end_borrows meta config bids + | FailMutLoan bid -> end_borrow meta config bid + | FailReservedMutBorrow bid -> promote_reserved_mut_borrow meta config bid | FailSymbolic (i, sp) -> (* Expand the symbolic value *) let proj, _ = @@ -464,7 +464,7 @@ let rec update_ctx_along_read_place (meta : Meta.meta) (config : config) (access (List.length p.projection - i) in let prefix = { p with projection = proj } in - expand_symbolic_value_no_branching config sp + expand_symbolic_value_no_branching meta config sp (Some (Synth.mk_mplace meta prefix ctx)) | FailBottom (_, _, _) -> (* We can't expand {!Bottom} values while reading them *) @@ -484,12 +484,12 @@ let rec update_ctx_along_write_place (meta : Meta.meta) (config : config) (acces (* Update the context *) let cc = match err with - | FailSharedLoan bids -> end_borrows config bids - | FailMutLoan bid -> end_borrow config bid - | FailReservedMutBorrow bid -> promote_reserved_mut_borrow config bid + | FailSharedLoan bids -> end_borrows meta config bids + | FailMutLoan bid -> end_borrow meta config bid + | FailReservedMutBorrow bid -> promote_reserved_mut_borrow meta config bid | FailSymbolic (_pe, sp) -> (* Expand the symbolic value *) - expand_symbolic_value_no_branching config sp + expand_symbolic_value_no_branching meta config sp (Some (Synth.mk_mplace meta p ctx)) | FailBottom (remaining_pes, pe, ty) -> (* Expand the {!Bottom} value *) @@ -525,7 +525,7 @@ let rec end_loans_at_place (meta : Meta.meta) (config : config) (access : access (* Nothing special to do *) super#visit_borrow_content env bc | VReservedMutBorrow bid -> (* We need to activate reserved borrows *) - let cc = promote_reserved_mut_borrow config bid in + let cc = promote_reserved_mut_borrow meta config bid in raise (UpdateCtx cc) method! visit_loan_content env lc = @@ -536,11 +536,11 @@ let rec end_loans_at_place (meta : Meta.meta) (config : config) (access : access match access with | Read -> super#visit_VSharedLoan env bids v | Write | Move -> - let cc = end_borrows config bids in + let cc = end_borrows meta config bids in raise (UpdateCtx cc)) | VMutLoan bid -> (* We always need to end mutable borrows *) - let cc = end_borrow config bid in + let cc = end_borrow meta config bid in raise (UpdateCtx cc) end in @@ -568,7 +568,7 @@ let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) * a dummy variable *) let access = Write in let v = read_place meta access p ctx in - let ctx = write_place meta access p (mk_bottom v.ty) ctx in + let ctx = write_place meta access p (mk_bottom meta v.ty) ctx in let dummy_id = fresh_dummy_var_id () in let ctx = ctx_push_dummy_var ctx dummy_id v in (* Auxiliary function *) @@ -586,8 +586,8 @@ let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) (* There are: end them then retry *) let cc = match c with - | LoanContent (VSharedLoan (bids, _)) -> end_borrows config bids - | LoanContent (VMutLoan bid) -> end_borrow config bid + | LoanContent (VSharedLoan (bids, _)) -> end_borrows meta config bids + | LoanContent (VMutLoan bid) -> end_borrow meta config bid | BorrowContent _ -> craise meta "Unreachable" in (* Retry *) @@ -603,7 +603,7 @@ let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) (* Reinsert *) let ctx = write_place meta access p v ctx in (* Sanity check *) - assert (not (outer_loans_in_value v)); + cassert (not (outer_loans_in_value v)) meta "TODO: Error message"; (* Continue *) cf ctx) in @@ -616,7 +616,7 @@ let prepare_lplace (meta : Meta.meta) (config : config) (p : place) (cf : typed_ log#ldebug (lazy ("prepare_lplace:" ^ "\n- p: " ^ place_to_string ctx p - ^ "\n- Initial context:\n" ^ eval_ctx_to_string ctx)); + ^ "\n- Initial context:\n" ^ eval_ctx_to_string meta ctx)); (* Access the place *) let access = Write in let cc = update_ctx_along_write_place meta config access p in @@ -627,7 +627,7 @@ let prepare_lplace (meta : Meta.meta) (config : config) (p : place) (cf : typed_ fun ctx -> let v = read_place meta access p ctx in (* Sanity checks *) - assert (not (outer_loans_in_value v)); + cassert (not (outer_loans_in_value v)) meta "TODO: Error message"; (* Continue *) cf v ctx in diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index 3e29b810..faa68688 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -13,13 +13,13 @@ type access_kind = Read | Write | Move updates the environment (by ending borrows, expanding symbolic values, etc.) until it manages to fully access the provided place. *) -val update_ctx_along_read_place : config -> access_kind -> place -> cm_fun +val update_ctx_along_read_place : Meta.meta -> config -> access_kind -> place -> cm_fun (** Update the environment to be able to write to a place. See {!update_ctx_along_read_place}. *) -val update_ctx_along_write_place : config -> access_kind -> place -> cm_fun +val update_ctx_along_write_place : Meta.meta -> config -> access_kind -> place -> cm_fun (** Read the value at a given place. @@ -29,7 +29,7 @@ val update_ctx_along_write_place : config -> access_kind -> place -> cm_fun Note that we only access the value at the place, and do not check that the value is "well-formed" (for instance that it doesn't contain bottoms). *) -val read_place : access_kind -> place -> eval_ctx -> typed_value +val read_place : Meta.meta -> access_kind -> place -> eval_ctx -> typed_value (** Update the value at a given place. @@ -40,20 +40,21 @@ val read_place : access_kind -> place -> eval_ctx -> typed_value the overwritten value contains borrows, loans, etc. and will simply overwrite it. *) -val write_place : access_kind -> place -> typed_value -> eval_ctx -> eval_ctx +val write_place : Meta.meta -> access_kind -> place -> typed_value -> eval_ctx -> eval_ctx (** Compute an expanded tuple ⊥ value. [compute_expanded_bottom_tuple_value [ty0, ..., tyn]] returns [(⊥:ty0, ..., ⊥:tyn)] *) -val compute_expanded_bottom_tuple_value : ety list -> typed_value +val compute_expanded_bottom_tuple_value : Meta.meta -> ety list -> typed_value (** Compute an expanded ADT ⊥ value. The types in the generics should use erased regions. *) val compute_expanded_bottom_adt_value : + Meta.meta -> eval_ctx -> TypeDeclId.id -> VariantId.id option -> @@ -73,7 +74,7 @@ val compute_expanded_bottom_adt_value : that the place is *inside* a borrow, if we end the borrow, we won't be able to reinsert the value back). *) -val drop_outer_loans_at_lplace : config -> place -> cm_fun +val drop_outer_loans_at_lplace : Meta.meta -> config -> place -> cm_fun (** End the loans at a given place: read the value, if it contains a loan, end this loan, repeat. @@ -84,7 +85,7 @@ val drop_outer_loans_at_lplace : config -> place -> cm_fun when moving values, we can't move a value which contains loans and thus need to end them, etc. *) -val end_loans_at_place : config -> access_kind -> place -> cm_fun +val end_loans_at_place : Meta.meta -> config -> access_kind -> place -> cm_fun (** Small utility. @@ -95,4 +96,4 @@ val end_loans_at_place : config -> access_kind -> place -> cm_fun place. This value should not contain any outer loan (and we check it is the case). Note that this value is very likely to contain ⊥ subvalues. *) -val prepare_lplace : config -> place -> (typed_value -> m_fun) -> m_fun +val prepare_lplace : Meta.meta -> config -> place -> (typed_value -> m_fun) -> m_fun diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index d4a237b2..fff23aec 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -18,7 +18,7 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) (* Sanity check - TODO: move those elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Subst.erase_regions ty in - assert (ty_is_rty ty && ety = v.ty); + cassert (ty_is_rty ty && ety = v.ty) meta "TODO: error message"; (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then [] else @@ -27,7 +27,7 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics + Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id generics in (* Project over the field values *) @@ -84,7 +84,7 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VLoan _, _ -> craise meta "Unreachable" | VSymbolic s, _ -> (* Check that the projection doesn't contain ended regions *) - assert (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)); + cassert (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) meta "TODO: error message"; [ AsbProjReborrows (s, ty) ] | _ -> craise meta "Unreachable" @@ -95,7 +95,7 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Substitute.erase_regions ty in - assert (ty_is_rty ty && ety = v.ty); + cassert (ty_is_rty ty && ety = v.ty) meta "TODO: error message"; (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then { value = AIgnored; ty } else @@ -105,7 +105,7 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics + Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id generics in (* Project over the field values *) let fields_types = List.combine adt.field_values field_types in @@ -212,13 +212,13 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " ^ RegionId.Set.to_string None rset2 ^ "\n")); - assert (not (projections_intersect meta ty1 rset1 ty2 rset2))); + cassert (not (projections_intersect meta ty1 rset1 ty2 rset2))) meta "TODO: error message"; ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror (lazy ("apply_proj_borrows: unexpected inputs:\n- input value: " - ^ typed_value_to_string ctx v + ^ typed_value_to_string meta ctx v ^ "\n- proj rty: " ^ ty_to_string ctx ty)); craise meta "Unreachable" in @@ -261,7 +261,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI (original_sv_ty : rty) : typed_avalue = (* Sanity check: if we have a proj_loans over a symbolic value, it should * contain regions which we will project *) - assert (ty_has_regions_in_set regions original_sv_ty); + cassert (ty_has_regions_in_set regions original_sv_ty) meta "TODO: error message"; (* Match *) let (value, ty) : avalue * ty = match (see, original_sv_ty) with @@ -276,7 +276,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI (AAdt { variant_id; field_values }, original_sv_ty) | SeMutRef (bid, spc), TRef (r, ref_ty, RMut) -> (* Sanity check *) - assert (spc.sv_ty = ref_ty); + cassert (spc.sv_ty = ref_ty) meta "TODO: error message"; (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in (* Check if the region is in the set of projected regions (note that @@ -294,7 +294,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI (ALoan (AIgnoredMutLoan (opt_bid, child_av)), ref_ty) | SeSharedRef (bids, spc), TRef (r, ref_ty, RShared) -> (* Sanity check *) - assert (spc.sv_ty = ref_ty); + cassert (spc.sv_ty = ref_ty) meta "TODO: error message"; (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in (* Check if the region is in the set of projected regions (note that @@ -332,7 +332,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI borrows - easy - and mutable borrows - in this case, we reborrow the whole borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]). *) -let apply_reborrows (reborrows : (BorrowId.id * BorrowId.id) list) +let apply_reborrows (meta : Meta.meta) (reborrows : (BorrowId.id * BorrowId.id) list) (ctx : eval_ctx) : eval_ctx = (* This is a bit brutal, but whenever we insert a reborrow, we remove * it from the list. This allows us to check that all the reborrows were @@ -464,7 +464,7 @@ let apply_reborrows (reborrows : (BorrowId.id * BorrowId.id) list) (* Visit *) let ctx = obj#visit_eval_ctx () ctx in (* Check that there are no reborrows remaining *) - assert (!reborrows = []); + cassert (!reborrows = []) meta "TODO: error message"; (* Return *) ctx @@ -483,11 +483,11 @@ let prepare_reborrows (meta : Meta.meta) (config : config) (allow_reborrows : bo let apply_registered_reborrows (ctx : eval_ctx) : eval_ctx = match config.mode with | ConcreteMode -> - assert (!reborrows = []); + cassert (!reborrows = []) meta "TODO: error message"; ctx | SymbolicMode -> (* Apply the reborrows *) - apply_reborrows !reborrows ctx + apply_reborrows meta !reborrows ctx in (fresh_reborrow, apply_registered_reborrows) @@ -495,7 +495,7 @@ let prepare_reborrows (meta : Meta.meta) (config : config) (allow_reborrows : bo let apply_proj_borrows_on_input_value (meta : Meta.meta) (config : config) (ctx : eval_ctx) (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = - assert (ty_is_rty ty); + cassert (ty_is_rty ty) meta "TODO: error message"; let check_symbolic_no_ended = true in let allow_reborrows = true in (* Prepare the reborrows *) diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index 9e4ebc20..7ffe4917 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -15,11 +15,11 @@ open Contexts [original_sv_ty]: shouldn't have erased regions *) val apply_proj_loans_on_symbolic_expansion : - RegionId.Set.t -> RegionId.Set.t -> symbolic_expansion -> rty -> typed_avalue + Meta.meta -> RegionId.Set.t -> RegionId.Set.t -> symbolic_expansion -> rty -> typed_avalue (** Convert a symbolic expansion *which is not a borrow* to a value *) val symbolic_expansion_non_borrow_to_value : - symbolic_value -> symbolic_expansion -> typed_value + Meta.meta -> symbolic_value -> symbolic_expansion -> typed_value (** Convert a symbolic expansion *which is not a shared borrow* to a value. @@ -28,7 +28,7 @@ val symbolic_expansion_non_borrow_to_value : during a symbolic expansion. *) val symbolic_expansion_non_shared_borrow_to_value : - symbolic_value -> symbolic_expansion -> typed_value + Meta.meta -> symbolic_value -> symbolic_expansion -> typed_value (** Auxiliary function to prepare reborrowing operations (used when applying projectors). @@ -43,7 +43,7 @@ val symbolic_expansion_non_shared_borrow_to_value : - [allow_reborrows] *) val prepare_reborrows : - config -> bool -> (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) + Meta.meta -> config -> bool -> (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) (** Apply (and reduce) a projector over borrows to an avalue. We use this for instance to spread the borrows present in the inputs @@ -96,6 +96,7 @@ val prepare_reborrows : then we interpret the borrow [l] as belonging to region [r] *) val apply_proj_borrows : + Meta.meta -> bool -> eval_ctx -> (BorrowId.id -> BorrowId.id) -> @@ -115,6 +116,7 @@ val apply_proj_borrows : erased regions) *) val apply_proj_borrows_on_input_value : + Meta.meta -> config -> eval_ctx -> RegionId.Set.t -> diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 8ccdcc93..e71b7b68 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -19,33 +19,33 @@ module S = SynthesizeSymbolic let log = L.statements_log (** Drop a value at a given place - TODO: factorize this with [assign_to_place] *) -let drop_value (config : config) (p : place) : cm_fun = +let drop_value (meta : Meta.meta) (config : config) (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx)); (* Note that we use [Write], not [Move]: we allow to drop values *below* borrows *) let access = Write in (* First make sure we can access the place, by ending loans or expanding * symbolic values along the path, for instance *) - let cc = update_ctx_along_read_place config access p in + let cc = update_ctx_along_read_place meta config access p in (* Prepare the place (by ending the outer loans *at* the place). *) - let cc = comp cc (prepare_lplace config p) in + let cc = comp cc (prepare_lplace meta config p) in (* Replace the value with {!Bottom} *) let replace cf (v : typed_value) ctx = (* Move the value at destination (that we will overwrite) to a dummy variable * to preserve the borrows it may contain *) - let mv = InterpreterPaths.read_place access p ctx in + let mv = InterpreterPaths.read_place meta access p ctx in let dummy_id = fresh_dummy_var_id () in let ctx = ctx_push_dummy_var ctx dummy_id mv in (* Update the destination to ⊥ *) let nv = { v with value = VBottom } in - let ctx = write_place access p nv ctx in + let ctx = write_place meta access p nv ctx in log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx)); cf ctx in (* Compose and apply *) @@ -99,14 +99,14 @@ let assign_to_place (meta : Meta.meta) (config : config) (rv : typed_value) (p : log#ldebug (lazy ("assign_to_place:" ^ "\n- rv: " - ^ typed_value_to_string ctx rv + ^ typed_value_to_string meta ctx rv ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx)); (* Push the rvalue to a dummy variable, for bookkeeping *) let rvalue_vid = fresh_dummy_var_id () in let cc = push_dummy_var rvalue_vid rv in (* Prepare the destination *) - let cc = comp cc (prepare_lplace config p) in + let cc = comp cc (prepare_lplace meta config p) in (* Retrieve the rvalue from the dummy variable *) let cc = comp cc (fun cf _lv -> remove_dummy_var meta rvalue_vid cf) in (* Update the destination *) @@ -114,21 +114,21 @@ let assign_to_place (meta : Meta.meta) (config : config) (rv : typed_value) (p : fun ctx -> (* Move the value at destination (that we will overwrite) to a dummy variable * to preserve the borrows *) - let mv = InterpreterPaths.read_place Write p ctx in + let mv = InterpreterPaths.read_place meta Write p ctx in let dest_vid = fresh_dummy_var_id () in let ctx = ctx_push_dummy_var ctx dest_vid mv in (* Write to the destination *) (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) cassert (not (bottom_in_value ctx.ended_regions rv)) meta "TODO: Error message"; (* Update the destination *) - let ctx = write_place Write p rv ctx in + let ctx = write_place meta Write p rv ctx in (* Debug *) log#ldebug (lazy ("assign_to_place:" ^ "\n- rv: " - ^ typed_value_to_string ctx rv + ^ typed_value_to_string meta ctx rv ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string ctx)); + ^ eval_ctx_to_string meta ctx)); (* Continue *) cf ctx in @@ -140,7 +140,7 @@ let eval_assertion_concrete (meta : Meta.meta) (config : config) (assertion : as st_cm_fun = fun cf ctx -> (* There won't be any symbolic expansions: fully evaluate the operand *) - let eval_op = eval_operand config assertion.cond in + let eval_op = eval_operand meta config assertion.cond in let eval_assert cf (v : typed_value) : m_fun = fun ctx -> match v.value with @@ -149,7 +149,7 @@ let eval_assertion_concrete (meta : Meta.meta) (config : config) (assertion : as if b = assertion.expected then cf Unit ctx else cf Panic ctx | _ -> craise - meta ("Expected a boolean, got: " ^ typed_value_to_string ctx v) + meta ("Expected a boolean, got: " ^ typed_value_to_string meta ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -163,7 +163,7 @@ let eval_assertion_concrete (meta : Meta.meta) (config : config) (assertion : as let eval_assertion (meta : Meta.meta) (config : config) (assertion : assertion) : st_cm_fun = fun cf ctx -> (* Evaluate the operand *) - let eval_op = eval_operand config assertion.cond in + let eval_op = eval_operand meta config assertion.cond in (* Evaluate the assertion *) let eval_assert cf (v : typed_value) : m_fun = fun ctx -> @@ -185,7 +185,7 @@ let eval_assertion (meta : Meta.meta) (config : config) (assertion : assertion) * We will of course synthesize an assertion in the generated code * (see below). *) let ctx = - apply_symbolic_expansion_non_borrow config sv (SeLiteral (VBool true)) + apply_symbolic_expansion_non_borrow meta config sv (SeLiteral (VBool true)) ctx in (* Continue *) @@ -194,7 +194,7 @@ let eval_assertion (meta : Meta.meta) (config : config) (assertion : assertion) S.synthesize_assertion ctx v expr | _ -> craise - meta ("Expected a boolean, got: " ^ typed_value_to_string ctx v) + meta ("Expected a boolean, got: " ^ typed_value_to_string meta ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -218,11 +218,11 @@ let set_discriminant (meta : Meta.meta) (config : config) (p : place) (variant_i ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p ^ "\n- variant id: " ^ VariantId.to_string variant_id - ^ "\n- initial context:\n" ^ eval_ctx_to_string ctx)); + ^ "\n- initial context:\n" ^ eval_ctx_to_string meta ctx)); (* Access the value *) let access = Write in - let cc = update_ctx_along_read_place config access p in - let cc = comp cc (prepare_lplace config p) in + let cc = update_ctx_along_read_place meta config access p in + let cc = comp cc (prepare_lplace meta config p) in (* Update the value *) let update_value cf (v : typed_value) : m_fun = fun ctx -> @@ -244,7 +244,7 @@ let set_discriminant (meta : Meta.meta) (config : config) (p : place) (variant_i let bottom_v = match type_id with | TAdtId def_id -> - compute_expanded_bottom_adt_value ctx def_id + compute_expanded_bottom_adt_value meta ctx def_id (Some variant_id) generics | _ -> craise meta "Unreachable" in @@ -253,7 +253,7 @@ let set_discriminant (meta : Meta.meta) (config : config) (p : place) (variant_i let bottom_v = match type_id with | TAdtId def_id -> - compute_expanded_bottom_adt_value ctx def_id (Some variant_id) + compute_expanded_bottom_adt_value meta ctx def_id (Some variant_id) generics | _ -> craise meta "Unreachable" in @@ -311,12 +311,12 @@ let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : in AssociatedTypes.ctx_normalize_erase_ty ctx ty -let move_return_value (config : config) (pop_return_value : bool) +let move_return_value (config : config) (meta : Meta.meta) (pop_return_value : bool) (cf : typed_value option -> m_fun) : m_fun = fun ctx -> if pop_return_value then let ret_vid = VarId.zero in - let cc = eval_operand config (Move (mk_place_from_var_id ret_vid)) in + let cc = eval_operand meta config (Move (mk_place_from_var_id ret_vid)) in cc (fun v ctx -> cf (Some v) ctx) ctx else cf None ctx @@ -324,7 +324,7 @@ let pop_frame (meta : Meta.meta) (config : config) (pop_return_value : bool) (cf : typed_value option -> m_fun) : m_fun = fun ctx -> (* Debug *) - log#ldebug (lazy ("pop_frame:\n" ^ eval_ctx_to_string ctx)); + log#ldebug (lazy ("pop_frame:\n" ^ eval_ctx_to_string meta ctx)); (* List the local variables, but the return variable *) let ret_vid = VarId.zero in @@ -347,7 +347,7 @@ let pop_frame (meta : Meta.meta) (config : config) (pop_return_value : bool) ^ "]")); (* Move the return value out of the return variable *) - let cc = move_return_value config pop_return_value in + let cc = move_return_value config meta pop_return_value in (* Sanity check *) let cc = comp_check_value cc (fun ret_value ctx -> @@ -364,7 +364,7 @@ let pop_frame (meta : Meta.meta) (config : config) (pop_return_value : bool) let cf_drop = List.fold_left (fun cf lid -> - drop_outer_loans_at_lplace config (mk_place_from_var_id lid) cf) + drop_outer_loans_at_lplace meta config (mk_place_from_var_id lid) cf) (cf ret_value) locals in (* Apply *) @@ -377,7 +377,7 @@ let pop_frame (meta : Meta.meta) (config : config) (pop_return_value : bool) log#ldebug (lazy ("pop_frame: after dropping outer loans in local variables:\n" - ^ eval_ctx_to_string ctx))) + ^ eval_ctx_to_string meta ctx))) in (* Pop the frame - we remove the [Frame] delimiter, and reintroduce all @@ -427,7 +427,7 @@ let eval_box_new_concrete (meta : Meta.meta) (config : config) (generics : gener (* Move the input value *) let cf_move = - eval_operand config (Move (mk_place_from_var_id input_var.index)) + eval_operand meta config (Move (mk_place_from_var_id input_var.index)) in (* Create the new box *) @@ -438,7 +438,7 @@ let eval_box_new_concrete (meta : Meta.meta) (config : config) (generics : gener let box_v = VAdt { variant_id = None; field_values = [ moved_input_value ] } in - let box_v = mk_typed_value box_ty box_v in + let box_v = mk_typed_value meta box_ty box_v in (* Move this value to the return variable *) let dest = mk_place_from_var_id VarId.zero in @@ -477,12 +477,12 @@ let eval_box_free (meta : Meta.meta) (config : config) (generics : generic_args) match (generics.regions, generics.types, generics.const_generics, args) with | [], [ boxed_ty ], [], [ Move input_box_place ] -> (* Required type checking *) - let input_box = InterpreterPaths.read_place Write input_box_place ctx in + let input_box = InterpreterPaths.read_place meta Write input_box_place ctx in (let input_ty = ty_get_box input_box.ty in cassert (input_ty = boxed_ty)) meta "TODO: Error message"; (* Drop the value *) - let cc = drop_value config input_box_place in + let cc = drop_value meta config input_box_place in (* Update the destination by setting it to [()] *) let cc = comp cc (assign_to_place meta config mk_unit_value dest) in @@ -519,7 +519,7 @@ let eval_assumed_function_call_concrete (meta : Meta.meta) (config : config) (fi (* "Normal" case: not box_free *) (* Evaluate the operands *) (* let ctx, args_vl = eval_operands config ctx args in *) - let cf_eval_ops = eval_operands config args in + let cf_eval_ops = eval_operands meta config args in (* Evaluate the call * @@ -758,7 +758,7 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call ctx.fun_ctx.regions_hierarchies in let inst_sg = - instantiate_fun_sig ctx func.generics tr_self def.signature + instantiate_fun_sig meta ctx func.generics tr_self def.signature regions_hierarchy in (func.func, func.generics, None, def, regions_hierarchy, inst_sg) @@ -805,7 +805,7 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call ctx.fun_ctx.regions_hierarchies in let inst_sg = - instantiate_fun_sig ctx generics tr_self + instantiate_fun_sig meta ctx generics tr_self method_def.signature regions_hierarchy in (* Also update the function identifier: we want to forget @@ -871,7 +871,7 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call in let tr_self = TraitRef trait_ref in let inst_sg = - instantiate_fun_sig ctx all_generics tr_self + instantiate_fun_sig meta ctx all_generics tr_self method_def.signature regions_hierarchy in ( func.func, @@ -913,7 +913,7 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call in let tr_self = TraitRef trait_ref in let inst_sg = - instantiate_fun_sig ctx generics tr_self method_def.signature + instantiate_fun_sig meta ctx generics tr_self method_def.signature regions_hierarchy in ( func.func, @@ -924,22 +924,22 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call inst_sg ))) (** Evaluate a statement *) -let rec eval_statement (meta : Meta.meta) (config : config) (st : statement) : st_cm_fun = +let rec eval_statement (config : config) (st : statement) : st_cm_fun = fun cf ctx -> (* Debugging *) log#ldebug (lazy ("\n**About to evaluate statement**: [\n" ^ statement_to_string_with_tab ctx st - ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string ctx ^ "\n\n")); + ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string st.meta ctx ^ "\n\n")); (* Take a snapshot of the current context for the purpose of generating pretty names *) let cc = S.cf_save_snapshot in (* Expand the symbolic values if necessary - we need to do that before * checking the invariants *) - let cc = comp cc (greedy_expand_symbolic_values config) in + let cc = comp cc (greedy_expand_symbolic_values st.meta config) in (* Sanity check *) - let cc = comp cc (Invariants.cf_check_invariants meta) in + let cc = comp cc (Invariants.cf_check_invariants st.meta) in (* Evaluate *) let cf_eval_st cf : m_fun = @@ -955,47 +955,47 @@ let rec eval_statement (meta : Meta.meta) (config : config) (st : statement) : s match rvalue with | Global (gid, generics) -> (* Evaluate the global *) - eval_global meta config p gid generics cf ctx + eval_global config p gid generics cf ctx | _ -> (* Evaluate the rvalue *) - let cf_eval_rvalue = eval_rvalue_not_global config rvalue in + let cf_eval_rvalue = eval_rvalue_not_global st.meta config rvalue in (* Assign *) let cf_assign cf (res : (typed_value, eval_error) result) ctx = log#ldebug (lazy ("about to assign to place: " ^ place_to_string ctx p - ^ "\n- Context:\n" ^ eval_ctx_to_string ctx)); + ^ "\n- Context:\n" ^ eval_ctx_to_string st.meta ctx)); match res with | Error EPanic -> cf Panic ctx | Ok rv -> ( - let expr = assign_to_place meta config rv p (cf Unit) ctx in + let expr = assign_to_place st.meta config rv p (cf Unit) ctx in (* Update the synthesized AST - here we store meta-information. * We do it only in specific cases (it is not always useful, and * also it can lead to issues - for instance, if we borrow a * reserved borrow, we later can't translate it to pure values...) *) match rvalue with - | Global _ -> craise meta "Unreachable" + | Global _ -> craise st.meta "Unreachable" | Use _ | RvRef (_, (BShared | BMut | BTwoPhaseMut | BShallow)) | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> let rp = rvalue_get_place rvalue in let rp = match rp with - | Some rp -> Some (S.mk_mplace meta rp ctx) + | Some rp -> Some (S.mk_mplace st.meta rp ctx) | None -> None in - S.synthesize_assignment ctx (S.mk_mplace meta p ctx) rv rp expr + S.synthesize_assignment ctx (S.mk_mplace st.meta p ctx) rv rp expr ) in (* Compose and apply *) comp cf_eval_rvalue cf_assign cf ctx) - | FakeRead p -> eval_fake_read config p (cf Unit) ctx + | FakeRead p -> eval_fake_read st.meta config p (cf Unit) ctx | SetDiscriminant (p, variant_id) -> - set_discriminant meta config p variant_id cf ctx - | Drop p -> drop_value config p (cf Unit) ctx - | Assert assertion -> eval_assertion meta config assertion cf ctx - | Call call -> eval_function_call meta config call cf ctx + set_discriminant st.meta config p variant_id cf ctx + | Drop p -> drop_value st.meta config p (cf Unit) ctx + | Assert assertion -> eval_assertion st.meta config assertion cf ctx + | Call call -> eval_function_call st.meta config call cf ctx | Panic -> cf Panic ctx | Return -> cf Return ctx | Break i -> cf (Break i) ctx @@ -1003,12 +1003,12 @@ let rec eval_statement (meta : Meta.meta) (config : config) (st : statement) : s | Nop -> cf Unit ctx | Sequence (st1, st2) -> (* Evaluate the first statement *) - let cf_st1 = eval_statement meta config st1 in + let cf_st1 = eval_statement config st1 in (* Evaluate the sequence *) let cf_st2 cf res = match res with (* Evaluation successful: evaluate the second statement *) - | Unit -> eval_statement meta config st2 cf + | Unit -> eval_statement config st2 cf (* Control-flow break: transmit. We enumerate the cases on purpose *) | Panic | Break _ | Continue _ | Return | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> @@ -1018,14 +1018,14 @@ let rec eval_statement (meta : Meta.meta) (config : config) (st : statement) : s comp cf_st1 cf_st2 cf ctx | Loop loop_body -> InterpreterLoops.eval_loop config st.meta - (eval_statement meta config loop_body) + (eval_statement config loop_body) cf ctx - | Switch switch -> eval_switch meta config switch cf ctx + | Switch switch -> eval_switch st.meta config switch cf ctx in (* Compose and apply *) comp cc cf_eval_st cf ctx -and eval_global (meta : Meta.meta) (config : config) (dest : place) (gid : GlobalDeclId.id) +and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) (generics : generic_args) : st_cm_fun = fun cf ctx -> let global = ctx_lookup_global_decl ctx gid in @@ -1034,7 +1034,7 @@ and eval_global (meta : Meta.meta) (config : config) (dest : place) (gid : Globa (* Treat the evaluation of the global as a call to the global body *) let func = { func = FunId (FRegular global.body); generics } in let call = { func = FnOpRegular func; args = []; dest } in - (eval_transparent_function_call_concrete meta config global.body call) cf ctx + (eval_transparent_function_call_concrete global.meta config global.body call) cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) @@ -1052,7 +1052,7 @@ and eval_global (meta : Meta.meta) (config : config) (dest : place) (gid : Globa in let sval = mk_fresh_symbolic_value ty in let cc = - assign_to_place meta config (mk_typed_value_from_symbolic_value sval) dest + assign_to_place global.meta config (mk_typed_value_from_symbolic_value sval) dest in let e = cc (cf Unit) ctx in S.synthesize_global_eval gid generics sval e @@ -1074,7 +1074,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f match switch with | If (op, st1, st2) -> (* Evaluate the operand *) - let cf_eval_op = eval_operand config op in + let cf_eval_op = eval_operand meta config op in (* Switch on the value *) let cf_if (cf : st_m_fun) (op_v : typed_value) : m_fun = fun ctx -> @@ -1083,17 +1083,17 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f (* Evaluate the if and the branch body *) let cf_branch cf : m_fun = (* Branch *) - if b then eval_statement meta config st1 cf - else eval_statement meta config st2 cf + if b then eval_statement config st1 cf + else eval_statement config st2 cf in (* Compose the continuations *) cf_branch cf ctx | VSymbolic sv -> (* Expand the symbolic boolean, and continue by evaluating * the branches *) - let cf_true : st_cm_fun = eval_statement meta config st1 in - let cf_false : st_cm_fun = eval_statement meta config st2 in - expand_symbolic_bool config sv + let cf_true : st_cm_fun = eval_statement config st1 in + let cf_false : st_cm_fun = eval_statement config st2 in + expand_symbolic_bool meta config sv (S.mk_opt_place_from_op meta op ctx) cf_true cf_false cf ctx | _ -> craise meta "Inconsistent state" @@ -1102,7 +1102,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f comp cf_eval_op cf_if cf ctx | SwitchInt (op, int_ty, stgts, otherwise) -> (* Evaluate the operand *) - let cf_eval_op = eval_operand config op in + let cf_eval_op = eval_operand meta config op in (* Switch on the value *) let cf_switch (cf : st_m_fun) (op_v : typed_value) : m_fun = fun ctx -> @@ -1114,8 +1114,8 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f cassert (sv.int_ty = int_ty) meta "TODO: Error message"; (* Find the branch *) match List.find_opt (fun (svl, _) -> List.mem sv svl) stgts with - | None -> eval_statement meta config otherwise cf - | Some (_, tgt) -> eval_statement meta config tgt cf + | None -> eval_statement config otherwise cf + | Some (_, tgt) -> eval_statement config tgt cf in (* Compose *) cf_eval_branch cf ctx @@ -1124,7 +1124,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f * proper branches *) let stgts = List.map - (fun (cv, tgt_st) -> (cv, eval_statement meta config tgt_st)) + (fun (cv, tgt_st) -> (cv, eval_statement config tgt_st)) stgts in (* Several branches may be grouped together: every branch is described @@ -1138,9 +1138,9 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f stgts) in (* Translate the otherwise branch *) - let otherwise = eval_statement meta config otherwise in + let otherwise = eval_statement config otherwise in (* Expand and continue *) - expand_symbolic_int config sv + expand_symbolic_int meta config sv (S.mk_opt_place_from_op meta op ctx) int_ty stgts otherwise cf ctx | _ -> craise meta "Inconsistent state" @@ -1152,7 +1152,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f let access = Read in let expand_prim_copy = false in let cf_read_p cf : m_fun = - access_rplace_reorganize_and_read config expand_prim_copy access p cf + access_rplace_reorganize_and_read meta config expand_prim_copy access p cf in (* Match on the value *) let cf_match (cf : st_m_fun) (p_v : typed_value) : m_fun = @@ -1170,12 +1170,12 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f | None -> ( match otherwise with | None -> craise meta "No otherwise branch" - | Some otherwise -> eval_statement meta config otherwise cf ctx) - | Some (_, tgt) -> eval_statement meta config tgt cf ctx) + | Some otherwise -> eval_statement config otherwise cf ctx) + | Some (_, tgt) -> eval_statement config tgt cf ctx) | VSymbolic sv -> (* Expand the symbolic value - may lead to branching *) let cf_expand = - expand_symbolic_adt config sv (Some (S.mk_mplace meta p ctx)) + expand_symbolic_adt meta config sv (Some (S.mk_mplace meta p ctx)) in (* Re-evaluate the switch - the value is not symbolic anymore, which means we will go to the other branch *) @@ -1251,7 +1251,7 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) - cassert (generics.trait_refs = []) meta "Traits are not supported yet TODO: error message"; + cassert (generics.trait_refs = []) body.meta "Traits are not supported yet TODO: error message"; (* There shouldn't be any reference to Self *) let tr_self = UnknownTrait __FUNCTION__ in let subst = @@ -1260,8 +1260,8 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - cassert (List.length args = body.arg_count) meta "TODO: Error message"; - let cc = eval_operands config args in + cassert (List.length args = body.arg_count) body.meta "TODO: Error message"; + let cc = eval_operands body.meta config args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result * of the operands evaluation from above to the functions afterwards, while @@ -1280,7 +1280,7 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) in let cc = - comp_transmit cc (push_var meta ret_var (mk_bottom ret_var.var_ty)) + comp_transmit cc (push_var meta ret_var (mk_bottom meta ret_var.var_ty)) in (* 2. Push the input values *) @@ -1323,9 +1323,9 @@ and eval_transparent_function_call_symbolic (meta : Meta.meta) (config : config) eval_transparent_function_call_symbolic_inst meta call ctx in (* Sanity check *) - cassert (List.length call.args = List.length def.signature.inputs) meta "TODO: Error message"; + cassert (List.length call.args = List.length def.signature.inputs) def.meta "TODO: Error message"; (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig meta config func def.signature + eval_function_call_symbolic_from_inst_sig def.meta config func def.signature regions_hierarchy inst_sg generics trait_method_generics call.args call.dest cf ctx @@ -1361,7 +1361,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.output in - let ret_spc = mk_fresh_symbolic_value ret_sv_ty in + let ret_spc = mk_fresh_symbolic_value meta ret_sv_ty in let ret_value = mk_typed_value_from_symbolic_value ret_spc in let ret_av regions = mk_aproj_loans_value_from_symbolic_value regions ret_spc @@ -1370,7 +1370,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi let dest_place = Some (S.mk_mplace meta dest ctx) in (* Evaluate the input operands *) - let cc = eval_operands config args in + let cc = eval_operands meta config args in (* Generate the abstractions and insert them in the context *) let abs_ids = List.map (fun rg -> rg.id) inst_sg.regions_hierarchy in @@ -1404,7 +1404,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi let ctx, args_projs = List.fold_left_map (fun ctx (arg, arg_rty) -> - apply_proj_borrows_on_input_value config ctx abs.regions + apply_proj_borrows_on_input_value meta config ctx abs.regions abs.ancestors_regions arg arg_rty) ctx args_with_rtypes in @@ -1461,7 +1461,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi abs_ids := with_loans_abs; (* End the abstractions which can be ended *) let no_loans_abs = AbstractionId.Set.of_list no_loans_abs in - let cc = InterpreterBorrows.end_abstractions config no_loans_abs in + let cc = InterpreterBorrows.end_abstractions meta config no_loans_abs in (* Recursive call *) let cc = comp cc end_abs_with_no_loans in (* Continue *) @@ -1529,7 +1529,7 @@ and eval_assumed_function_call_symbolic (meta : Meta.meta) (config : config) (fi let tr_self = UnknownTrait __FUNCTION__ in let sg = Assumed.get_assumed_fun_sig fid in let inst_sg = - instantiate_fun_sig ctx generics tr_self sg regions_hierarchy + instantiate_fun_sig meta ctx generics tr_self sg regions_hierarchy in (sg, regions_hierarchy, inst_sg) in @@ -1542,14 +1542,14 @@ and eval_assumed_function_call_symbolic (meta : Meta.meta) (config : config) (fi and eval_function_body (meta : Meta.meta) (config : config) (body : statement) : st_cm_fun = fun cf ctx -> log#ldebug (lazy "eval_function_body:"); - let cc = eval_statement meta config body in + let cc = eval_statement config body in let cf_finish cf res = log#ldebug (lazy "eval_function_body: cf_finish"); (* Note that we *don't* check the result ({!Panic}, {!Return}, etc.): we * delegate the check to the caller. *) (* Expand the symbolic values if necessary - we need to do that before * checking the invariants *) - let cc = greedy_expand_symbolic_values config in + let cc = greedy_expand_symbolic_values body.meta config in (* Sanity check *) let cc = comp_check_ctx cc (Invariants.check_invariants meta) in (* Continue *) diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index 3832d02f..3b1285a6 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -16,7 +16,7 @@ open Cps If the boolean is false, we don't move the return value, and call the continuation with [None]. *) -val pop_frame : config -> bool -> (typed_value option -> m_fun) -> m_fun +val pop_frame : Meta.meta -> config -> bool -> (typed_value option -> m_fun) -> m_fun (** Helper. @@ -48,4 +48,4 @@ val create_push_abstractions_from_abs_region_groups : val eval_statement : config -> statement -> st_cm_fun (** Evaluate a statement seen as a function body *) -val eval_function_body : config -> statement -> st_cm_fun +val eval_function_body : Meta.meta -> config -> statement -> st_cm_fun diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 243cf67b..48869739 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -6,6 +6,7 @@ open LlbcAst open Utils open TypesUtils open Cps +open Errors (* TODO: we should probably rename the file to ContextsUtils *) @@ -16,10 +17,10 @@ let log = Logging.interpreter_log (** Auxiliary function - call a function which requires a continuation, and return the let context given to the continuation *) -let get_cf_ctx_no_synth (f : cm_fun) (ctx : eval_ctx) : eval_ctx = +let get_cf_ctx_no_synth (meta : Meta.meta) (f : cm_fun) (ctx : eval_ctx) : eval_ctx = let nctx = ref None in let cf ctx = - assert (!nctx = None); + cassert (!nctx = None) meta "TODO: error message"; nctx := Some ctx; None in @@ -61,9 +62,9 @@ let statement_to_string ctx = Print.EvalCtx.statement_to_string ctx "" " " let statement_to_string_with_tab ctx = Print.EvalCtx.statement_to_string ctx " " " " -let env_elem_to_string ctx = Print.EvalCtx.env_elem_to_string ctx "" " " -let env_to_string ctx env = eval_ctx_to_string { ctx with env } -let abs_to_string ctx = Print.EvalCtx.abs_to_string ctx "" " " +let env_elem_to_string meta ctx = Print.EvalCtx.env_elem_to_string meta ctx "" " " +let env_to_string meta ctx env = eval_ctx_to_string meta { ctx with env } +let abs_to_string meta ctx = Print.EvalCtx.abs_to_string meta ctx "" " " let same_symbolic_id (sv0 : symbolic_value) (sv1 : symbolic_value) : bool = sv0.sv_id = sv1.sv_id @@ -76,29 +77,29 @@ let mk_place_from_var_id (var_id : VarId.id) : place = { var_id; projection = [] } (** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (ty : ty) : symbolic_value = +let mk_fresh_symbolic_value (meta : Meta.meta) (ty : ty) : symbolic_value = (* Sanity check *) - assert (ty_is_rty ty); + cassert (ty_is_rty ty) meta "TODO: error message"; let sv_id = fresh_symbolic_value_id () in let svalue = { sv_id; sv_ty = ty } in svalue -let mk_fresh_symbolic_value_from_no_regions_ty (ty : ty) : symbolic_value = - assert (ty_no_regions ty); - mk_fresh_symbolic_value ty +let mk_fresh_symbolic_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : symbolic_value = + cassert (ty_no_regions ty) meta "TODO: error message"; + mk_fresh_symbolic_value meta ty (** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value (rty : ty) : typed_value = - assert (ty_is_rty rty); +let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = + cassert (ty_is_rty rty) meta "TODO: error message"; let ty = Substitute.erase_regions rty in (* Generate the fresh a symbolic value *) - let value = mk_fresh_symbolic_value rty in + let value = mk_fresh_symbolic_value meta rty in let value = VSymbolic value in { value; ty } -let mk_fresh_symbolic_typed_value_from_no_regions_ty (ty : ty) : typed_value = - assert (ty_no_regions ty); - mk_fresh_symbolic_typed_value ty +let mk_fresh_symbolic_typed_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : typed_value = + cassert (ty_no_regions ty) meta "TODO: error message"; + mk_fresh_symbolic_typed_value meta ty (** Create a typed value from a symbolic value. *) let mk_typed_value_from_symbolic_value (svalue : symbolic_value) : typed_value = @@ -124,9 +125,9 @@ let mk_aproj_loans_value_from_symbolic_value (regions : RegionId.Set.t) else { value = AIgnored; ty = svalue.sv_ty } (** Create a borrows projector from a symbolic value *) -let mk_aproj_borrows_from_symbolic_value (proj_regions : RegionId.Set.t) +let mk_aproj_borrows_from_symbolic_value (meta : Meta.meta) (proj_regions : RegionId.Set.t) (svalue : symbolic_value) (proj_ty : ty) : aproj = - assert (ty_is_rty proj_ty); + cassert (ty_is_rty proj_ty) meta "TODO: error message"; if ty_has_regions_in_set proj_regions proj_ty then AProjBorrows (svalue, proj_ty) else AIgnoredProjBorrows @@ -140,7 +141,7 @@ let borrow_in_asb (bid : BorrowId.id) (asb : abstract_shared_borrows) : bool = List.exists (borrow_is_asb bid) asb (** TODO: move *) -let remove_borrow_from_asb (bid : BorrowId.id) (asb : abstract_shared_borrows) : +let remove_borrow_from_asb (meta : Meta.meta) (bid : BorrowId.id) (asb : abstract_shared_borrows) : abstract_shared_borrows = let removed = ref 0 in let asb = @@ -152,7 +153,7 @@ let remove_borrow_from_asb (bid : BorrowId.id) (asb : abstract_shared_borrows) : false)) asb in - assert (!removed = 1); + cassert (!removed = 1) meta "TODO: error message"; asb (** We sometimes need to return a value whose type may vary depending on @@ -427,7 +428,7 @@ let empty_ids_set = fst (compute_ctxs_ids []) (** **WARNING**: this function doesn't compute the normalized types (for the trait type aliases). This should be computed afterwards. *) -let initialize_eval_ctx (ctx : decls_ctx) +let initialize_eval_ctx (meta : Meta.meta) (ctx : decls_ctx) (region_groups : RegionGroupId.id list) (type_vars : type_var list) (const_generic_vars : const_generic_var list) : eval_ctx = reset_global_counters (); @@ -436,7 +437,7 @@ let initialize_eval_ctx (ctx : decls_ctx) (List.map (fun (cg : const_generic_var) -> let ty = TLiteral cg.ty in - let cv = mk_fresh_symbolic_typed_value ty in + let cv = mk_fresh_symbolic_typed_value meta ty in (cg.index, cv)) const_generic_vars) in @@ -459,7 +460,7 @@ let initialize_eval_ctx (ctx : decls_ctx) region ids. This is mostly used in preparation of function calls (when evaluating in symbolic mode). *) -let instantiate_fun_sig (ctx : eval_ctx) (generics : generic_args) +let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (generics : generic_args) (tr_self : trait_instance_id) (sg : fun_sig) (regions_hierarchy : region_var_groups) : inst_fun_sig = log#ldebug @@ -498,8 +499,8 @@ let instantiate_fun_sig (ctx : eval_ctx) (generics : generic_args) (* Generate the type substitution Note that for now we don't support instantiating the type parameters with types containing regions. *) - assert (List.for_all TypesUtils.ty_no_regions generics.types); - assert (TypesUtils.trait_instance_id_no_regions tr_self); + cassert (List.for_all TypesUtils.ty_no_regions generics.types) meta "TODO: error message"; + cassert (TypesUtils.trait_instance_id_no_regions tr_self) meta "TODO: error message"; let tsubst = Substitute.make_type_subst_from_vars sg.generics.types generics.types in diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 871bf90d..a8077ab7 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -55,7 +55,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : (* Link all the id representants to a borrow information *) let borrows_infos : borrow_info BorrowId.Map.t ref = ref BorrowId.Map.empty in let context_to_string () : string = - eval_ctx_to_string ctx ^ "- representants:\n" + eval_ctx_to_string meta ctx ^ "- representants:\n" ^ ids_reprs_to_string " " !ids_reprs ^ "\n- info:\n" ^ borrows_infos_to_string " " !borrows_infos @@ -77,12 +77,12 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let infos = !borrows_infos in (* Use the first borrow id as representant *) let repr_bid = BorrowId.Set.min_elt bids in - assert (not (BorrowId.Map.mem repr_bid infos)); + cassert (not (BorrowId.Map.mem repr_bid infos)) meta "TODO: Error message"; (* Insert the mappings to the representant *) let reprs = BorrowId.Set.fold (fun bid reprs -> - assert (not (BorrowId.Map.mem bid reprs)); + cassert (not (BorrowId.Map.mem bid reprs)) meta "TODO: Error message"; BorrowId.Map.add bid repr_bid reprs) bids reprs in @@ -105,8 +105,8 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let reprs = !ids_reprs in let infos = !borrows_infos in (* Sanity checks *) - assert (not (BorrowId.Map.mem bid reprs)); - assert (not (BorrowId.Map.mem bid infos)); + cassert (not (BorrowId.Map.mem bid reprs)) meta "TODO: Error message"; + cassert (not (BorrowId.Map.mem bid infos)) meta "TODO: Error message"; (* Add the mapping for the representant *) let reprs = BorrowId.Map.add bid bid reprs in (* Add the mapping for the loan info *) @@ -212,10 +212,10 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : | RShared, (BShared | BReserved) | RMut, BMut -> () | _ -> craise meta "Invariant not satisfied"); (* A reserved borrow can't point to a value inside an abstraction *) - assert (kind <> BReserved || not info.loan_in_abs); + cassert (kind <> BReserved || not info.loan_in_abs) meta "A reserved borrow can't point to a value inside an abstraction"; (* Insert the borrow id *) let borrow_ids = info.borrow_ids in - assert (not (BorrowId.Set.mem bid borrow_ids)); + cassert (not (BorrowId.Set.mem bid borrow_ids)) meta "TODO: Error message"; let info = { info with borrow_ids = BorrowId.Set.add bid borrow_ids } in (* Update the info in the map *) update_info bid info @@ -270,7 +270,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : List.iter (fun (rkind, bid) -> let info = find_info bid in - assert (info.loan_kind = rkind)) + cassert (info.loan_kind = rkind) meta "Not all the ignored loans are present at the proper place") !ignored_loans; (* Then, check the borrow infos *) @@ -278,11 +278,11 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : (fun _ info -> (* Note that we can't directly compare the sets - I guess they are * different depending on the order in which we add the elements... *) - assert ( + cassert ( BorrowId.Set.elements info.loan_ids - = BorrowId.Set.elements info.borrow_ids); + = BorrowId.Set.elements info.borrow_ids) meta "TODO: Error message"; match info.loan_kind with - | RMut -> assert (BorrowId.Set.cardinal info.loan_ids = 1) + | RMut -> cassert (BorrowId.Set.cardinal info.loan_ids = 1) meta "TODO: Error message" | RShared -> ()) !borrows_infos @@ -290,14 +290,14 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : - borrows/loans can't contain ⊥ or reserved mut borrows - shared loans can't contain mutable loans *) -let check_borrowed_values_invariant (ctx : eval_ctx) : unit = +let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let visitor = object inherit [_] iter_eval_ctx as super method! visit_VBottom info = (* No ⊥ inside borrowed values *) - assert (Config.allow_bottom_below_borrow || not info.outer_borrow) + cassert (Config.allow_bottom_below_borrow || not info.outer_borrow) meta "There should be no ⊥ inside borrowed values" method! visit_ABottom _info = (* ⊥ inside an abstraction is not the same as in a regular value *) @@ -310,7 +310,7 @@ let check_borrowed_values_invariant (ctx : eval_ctx) : unit = | VSharedLoan (_, _) -> set_outer_shared info | VMutLoan _ -> (* No mutable loan inside a shared loan *) - assert (not info.outer_shared); + cassert (not info.outer_shared) meta "There should be no mutable loan inside a shared loan"; set_outer_mut info in (* Continue exploring *) @@ -322,7 +322,7 @@ let check_borrowed_values_invariant (ctx : eval_ctx) : unit = match bc with | VSharedBorrow _ -> set_outer_shared info | VReservedMutBorrow _ -> - assert (not info.outer_borrow); + cassert (not info.outer_borrow) meta "TODO: Error message"; set_outer_shared info | VMutBorrow (_, _) -> set_outer_mut info in @@ -369,7 +369,7 @@ let check_borrowed_values_invariant (ctx : eval_ctx) : unit = let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : unit = match (cv, ty) with - | VScalar sv, TInteger int_ty -> assert (sv.int_ty = int_ty) + | VScalar sv, TInteger int_ty -> cassert (sv.int_ty = int_ty) meta "TODO: Error message" | VBool _, TBool | VChar _, TChar -> () | _ -> craise meta "Erroneous typing" @@ -393,17 +393,17 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = method! visit_EBinding info binder v = (* We also check that the regions are erased *) - assert (ty_is_ety v.ty); + cassert (ty_is_ety v.ty) meta "The regions should be erased"; super#visit_EBinding info binder v method! visit_symbolic_value inside_abs v = (* Check that the types have regions *) - assert (ty_is_rty v.sv_ty); + cassert (ty_is_rty v.sv_ty) meta "The types should have regions"; super#visit_symbolic_value inside_abs v method! visit_typed_value info tv = (* Check that the types have erased regions *) - assert (ty_is_ety tv.ty); + cassert (ty_is_ety tv.ty) meta "The types should have erased regions"; (* Check the current pair (value, type) *) (match (tv.value, tv.ty) with | VLiteral cv, TLiteral ty -> check_literal_type meta cv ty @@ -413,13 +413,13 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - assert ( - List.length generics.regions = List.length def.generics.regions); - assert (List.length generics.types = List.length def.generics.types); + cassert ( + List.length generics.regions = List.length def.generics.regions) meta "TODO: Error message"; + cassert (List.length generics.types = List.length def.generics.types) meta "TODO: Error message"; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - assert (VariantId.to_int variant_id < List.length variants) + cassert (VariantId.to_int variant_id < List.length variants) meta "The variant id should be consistent" | None, Struct _ -> () | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) @@ -429,24 +429,24 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : typed_value * ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_value * ty) -> cassert (v.ty = ty) meta "The field types are not correct") fields_with_types (* Tuple case *) | VAdt av, TAdt (TTuple, generics) -> - assert (generics.regions = []); - assert (generics.const_generics = []); - assert (av.variant_id = None); + cassert (generics.regions = []) meta "TODO: Error message"; + cassert (generics.const_generics = []) meta "TODO: Error message"; + cassert (av.variant_id = None) meta "TODO: Error message"; (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) let fields_with_types = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : typed_value * ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_value * ty) -> cassert (v.ty = ty) meta "The fields does not have the proper values or there are not as many fields as field types at the same time TODO: error message") fields_with_types (* Assumed type case *) | VAdt av, TAdt (TAssumed aty_id, generics) -> ( - assert (av.variant_id = None); + cassert (av.variant_id = None) meta "TODO: Error message"; match ( aty_id, av.field_values, @@ -456,20 +456,20 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = with (* Box *) | TBox, [ inner_value ], [], [ inner_ty ], [] -> - assert (inner_value.ty = inner_ty) + cassert (inner_value.ty = inner_ty) meta "TODO: Error message" | TArray, inner_values, _, [ inner_ty ], [ cg ] -> (* *) - assert ( + cassert ( List.for_all (fun (v : typed_value) -> v.ty = inner_ty) - inner_values); + inner_values) meta "TODO: Error message"; (* The length is necessarily concrete *) let len = (ValuesUtils.literal_as_scalar (TypesUtils.const_generic_as_literal cg)) .value in - assert (Z.of_int (List.length inner_values) = len) + cassert (Z.of_int (List.length inner_values) = len) meta "TODO: Error message" | (TSlice | TStr), _, _, _, _ -> craise meta "Unexpected" | _ -> craise meta "Erroneous type") | VBottom, _ -> (* Nothing to check *) () @@ -481,27 +481,27 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - assert (sv.ty = ref_ty) + cassert (sv.ty = ref_ty) meta "TODO: Error message" | _ -> craise meta "Inconsistent context") | VMutBorrow (_, bv), RMut -> - assert ( + cassert ( (* Check that the borrowed value has the proper type *) - bv.ty = ref_ty) + bv.ty = ref_ty) meta "TODO: Error message" | _ -> craise meta "Erroneous typing") | VLoan lc, ty -> ( match lc with - | VSharedLoan (_, sv) -> assert (sv.ty = ty) + | VSharedLoan (_, sv) -> cassert (sv.ty = ty) meta "TODO: Error message" | VMutLoan bid -> ( (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in match glc with - | Concrete (VMutBorrow (_, bv)) -> assert (bv.ty = ty) + | Concrete (VMutBorrow (_, bv)) -> cassert (bv.ty = ty) meta "The borrowed value does not have the proper type" | Abstract (AMutBorrow (_, sv)) -> - assert (Substitute.erase_regions sv.ty = ty) + cassert (Substitute.erase_regions sv.ty = ty) meta "The borrowed value does not have the proper type" | _ -> craise meta "Inconsistent context")) | VSymbolic sv, ty -> let ty' = Substitute.erase_regions sv.sv_ty in - assert (ty' = ty) + cassert (ty' = ty) meta "TODO: Error message" | _ -> craise meta "Erroneous typing"); (* Continue exploring to inspect the subterms *) super#visit_typed_value info tv @@ -516,7 +516,7 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * *) method! visit_typed_avalue info atv = (* Check that the types have regions *) - assert (ty_is_rty atv.ty); + cassert (ty_is_rty atv.ty) meta "The types should have regions"; (* Check the current pair (value, type) *) (match (atv.value, atv.ty) with (* ADT case *) @@ -525,16 +525,16 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - assert ( - List.length generics.regions = List.length def.generics.regions); - assert (List.length generics.types = List.length def.generics.types); - assert ( + cassert ( + List.length generics.regions = List.length def.generics.regions) meta "TODO: Error message"; + cassert (List.length generics.types = List.length def.generics.types) meta "TODO: Error message"; + cassert ( List.length generics.const_generics - = List.length def.generics.const_generics); + = List.length def.generics.const_generics) meta "TODO: Error message"; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - assert (VariantId.to_int variant_id < List.length variants) + cassert (VariantId.to_int variant_id < List.length variants) meta "The variant id should be consistent" | None, Struct _ -> () | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) @@ -544,24 +544,24 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : typed_avalue * ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_avalue * ty) -> cassert (v.ty = ty) meta "TODO: Error message") fields_with_types (* Tuple case *) | AAdt av, TAdt (TTuple, generics) -> - assert (generics.regions = []); - assert (generics.const_generics = []); - assert (av.variant_id = None); + cassert (generics.regions = []) meta "TODO: Error message"; + cassert (generics.const_generics = []) meta "TODO: Error message"; + cassert (av.variant_id = None) meta "TODO: Error message"; (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) let fields_with_types = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : typed_avalue * ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_avalue * ty) -> cassert (v.ty = ty) meta "The fields do not have the proper values or there are not as many fields as field types at the same time TODO: Error message") fields_with_types (* Assumed type case *) | AAdt av, TAdt (TAssumed aty_id, generics) -> ( - assert (av.variant_id = None); + cassert (av.variant_id = None) meta "TODO: Error message"; match ( aty_id, av.field_values, @@ -571,27 +571,27 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = with (* Box *) | TBox, [ boxed_value ], [], [ boxed_ty ], [] -> - assert (boxed_value.ty = boxed_ty) + cassert (boxed_value.ty = boxed_ty) meta "TODO: Error message" | _ -> craise meta "Erroneous type") | ABottom, _ -> (* Nothing to check *) () | ABorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with | AMutBorrow (_, av), RMut -> (* Check that the child value has the proper type *) - assert (av.ty = ref_ty) + cassert (av.ty = ref_ty) meta "TODO: Error message" | ASharedBorrow bid, RShared -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan meta ek_all bid ctx in match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - assert (sv.ty = Substitute.erase_regions ref_ty) + cassert (sv.ty = Substitute.erase_regions ref_ty) meta "TODO: Error message" | _ -> craise meta "Inconsistent context") - | AIgnoredMutBorrow (_opt_bid, av), RMut -> assert (av.ty = ref_ty) + | AIgnoredMutBorrow (_opt_bid, av), RMut -> cassert (av.ty = ref_ty) meta "TODO: Error message" | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, RMut ) -> - assert (given_back.ty = ref_ty); - assert (child.ty = ref_ty) + cassert (given_back.ty = ref_ty) meta "TODO: Error message"; + cassert (child.ty = ref_ty) meta "TODO: Error message" | AProjSharedBorrow _, RShared -> () | _ -> craise meta "Inconsistent context") | ALoan lc, aty -> ( @@ -599,54 +599,54 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | AMutLoan (bid, child_av) | AIgnoredMutLoan (Some bid, child_av) -> ( let borrowed_aty = aloan_get_expected_child_type aty in - assert (child_av.ty = borrowed_aty); + cassert (child_av.ty = borrowed_aty) meta "TODO: Error message"; (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> - assert (bv.ty = Substitute.erase_regions borrowed_aty) + cassert (bv.ty = Substitute.erase_regions borrowed_aty) meta "TODO: Error message" | Abstract (AMutBorrow (_, sv)) -> - assert ( + cassert ( Substitute.erase_regions sv.ty - = Substitute.erase_regions borrowed_aty) + = Substitute.erase_regions borrowed_aty) meta "TODO: Error message" | _ -> craise meta "Inconsistent context") | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - assert (child_av.ty = borrowed_aty) + cassert (child_av.ty = borrowed_aty) meta "TODO: Error message" | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - assert (sv.ty = Substitute.erase_regions borrowed_aty); + cassert (sv.ty = Substitute.erase_regions borrowed_aty) meta "TODO: Error message"; (* TODO: the type of aloans doesn't make sense, see above *) - assert (child_av.ty = borrowed_aty) + cassert (child_av.ty = borrowed_aty) meta "TODO: Error message" | AEndedMutLoan { given_back; child; given_back_meta = _ } | AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } -> let borrowed_aty = aloan_get_expected_child_type aty in - assert (given_back.ty = borrowed_aty); - assert (child.ty = borrowed_aty) + cassert (given_back.ty = borrowed_aty) meta "TODO: Error message"; + cassert (child.ty = borrowed_aty) meta "TODO: Error message" | AIgnoredSharedLoan child_av -> - assert (child_av.ty = aloan_get_expected_child_type aty)) + cassert (child_av.ty = aloan_get_expected_child_type aty) meta "TODO: Error message") | ASymbolic aproj, ty -> ( let ty1 = Substitute.erase_regions ty in match aproj with | AProjLoans (sv, _) -> let ty2 = Substitute.erase_regions sv.sv_ty in - assert (ty1 = ty2); + cassert (ty1 = ty2) meta "TODO: Error message"; (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - assert (ty_has_regions_in_set abs.regions sv.sv_ty) + cassert (ty_has_regions_in_set abs.regions sv.sv_ty) meta "The symbolic values should contain regions of interest or they should have been reduced to [] TODO: error message" | AProjBorrows (sv, proj_ty) -> let ty2 = Substitute.erase_regions sv.sv_ty in - assert (ty1 = ty2); + cassert (ty1 = ty2) meta "TODO: Error message"; (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - assert (ty_has_regions_in_set abs.regions proj_ty) + cassert (ty_has_regions_in_set abs.regions proj_ty) meta "The symbolic values should contain regions of interest or they should have been reduced to [] TODO: error message" | AEndedProjLoans (_msv, given_back_ls) -> List.iter (fun (_, proj) -> match proj with - | AProjBorrows (_sv, ty') -> assert (ty' = ty) + | AProjBorrows (_sv, ty') -> cassert (ty' = ty) meta "TODO: Error message" | AEndedProjBorrows _ | AIgnoredProjBorrows -> () | _ -> craise meta "Unexpected") given_back_ls @@ -657,7 +657,7 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (lazy ("Erroneous typing:" ^ "\n- raw value: " ^ show_typed_avalue atv ^ "\n- value: " - ^ typed_avalue_to_string ctx atv + ^ typed_avalue_to_string meta ctx atv ^ "\n- type: " ^ ty_to_string ctx atv.ty)); craise meta "Erroneous typing"); (* Continue exploring to inspect the subterms *) @@ -766,15 +766,15 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = *) (* A symbolic value can't be both in the regular environment and inside * projectors of borrows in abstractions *) - assert (info.env_count = 0 || info.aproj_borrows = []); + cassert (info.env_count = 0 || info.aproj_borrows = []) meta "A symbolic value can't be both in the regular environment and inside projectors of borrows in abstractions"; (* A symbolic value containing borrows can't be duplicated (i.e., copied): * it must be expanded first *) if ty_has_borrows ctx.type_ctx.type_infos info.ty then - assert (info.env_count <= 1); + cassert (info.env_count <= 1) meta "A symbolic value containing borrows can't be duplicated (i.e., copied): it must be expanded first"; (* A duplicated symbolic value is necessarily primitively copyable *) - assert (info.env_count <= 1 || ty_is_primitively_copyable info.ty); + cassert (info.env_count <= 1 || ty_is_primitively_copyable info.ty) meta "A duplicated symbolic value should necessarily be primitively copyable"; - assert (info.aproj_borrows = [] || info.aproj_loans <> []); + cassert (info.aproj_borrows = [] || info.aproj_loans <> []) meta "TODO: Error message"; (* At the same time: * - check that the loans don't intersect * - compute the set of regions for which we project loans @@ -786,7 +786,7 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = let regions = RegionId.Set.fold (fun rid regions -> - assert (not (RegionId.Set.mem rid regions)); + cassert (not (RegionId.Set.mem rid regions)) meta "The loan projectors should contain the region projectors"; RegionId.Set.add rid regions) regions linfo.regions in @@ -796,8 +796,8 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Check that the union of the loan projectors contains the borrow projections. *) List.iter (fun binfo -> - assert ( - projection_contains meta info.ty loan_regions binfo.proj_ty binfo.regions)) + cassert ( + projection_contains meta info.ty loan_regions binfo.proj_ty binfo.regions) meta "The union of the loan projectors should contain the borrow projections") info.aproj_borrows; () in @@ -806,9 +806,9 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = let check_invariants (meta : Meta.meta) (ctx : eval_ctx) : unit = if !Config.sanity_checks then ( - log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string ctx)); + log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string meta ctx)); check_loans_borrows_relation_invariant meta ctx; - check_borrowed_values_invariant ctx; + check_borrowed_values_invariant meta ctx; check_typing_invariant meta ctx; check_symbolic_values meta ctx) else log#ldebug (lazy "Not checking invariants (check is not activated)") diff --git a/compiler/Main.ml b/compiler/Main.ml index bea7e4a8..f860bec8 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -271,10 +271,10 @@ let () = (* Some options for the execution *) (* Test the unit functions with the concrete interpreter *) - if !test_unit_functions then Test.test_unit_functions meta m; + if !test_unit_functions then Test.test_unit_functions m; (* Translate the functions *) - Aeneas.Translate.translate_crate meta filename dest_dir m; + Aeneas.Translate.translate_crate filename dest_dir m; (* Print total elapsed time *) log#linfo diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index c6b098e6..3ea9c777 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -7,6 +7,7 @@ open Expressions open LlbcAst open Utils open LlbcAstUtils +open Errors let log = Logging.pre_passes_log @@ -214,11 +215,11 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = inherit [_] map_statement as super method! visit_Loop entered_loop loop = - assert (not entered_loop); + cassert (not entered_loop) st.meta "TODO: error message"; super#visit_Loop true loop method! visit_Break _ i = - assert (i = 0); + cassert (i = 0) st.meta "TODO: error message"; nst.content end in @@ -233,7 +234,7 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = method! visit_Sequence env st1 st2 = match st1.content with | Loop _ -> - assert (statement_has_no_loop_break_continue st2); + cassert (statement_has_no_loop_break_continue st2) st2.meta "TODO: error message"; (replace_breaks_with st1 st2).content | _ -> super#visit_Sequence env st1 st2 end @@ -392,13 +393,16 @@ let remove_shallow_borrows (crate : crate) (f : fun_decl) : fun_decl = let body = filter_visitor#visit_statement () body in (* Check that the filtered variables completely disappeared from the body *) + (* let statement = crate in *) let check_visitor = object - inherit [_] iter_statement - method! visit_var_id _ id = assert (not (VarId.Set.mem id !filtered)) + inherit [_] iter_statement as super + (* Remember the span of the statement we enter *) + method! visit_statement _ st = super#visit_statement st.meta st + method! visit_var_id meta id = cassert (not (VarId.Set.mem id !filtered)) meta "Filtered variables should have completely disappeared from the body" end in - check_visitor#visit_statement () body; + check_visitor#visit_statement body.meta body; (* Return the updated body *) body diff --git a/compiler/Print.ml b/compiler/Print.ml index 36aa2cb9..85e7eaf6 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -10,6 +10,7 @@ open ValuesUtils open Expressions open LlbcAst open Contexts +open Errors module Types = Charon.PrintTypes module Expressions = Charon.PrintExpressions @@ -42,12 +43,12 @@ module Values = struct * typed_avalue_to_string. At some point we had done it, because [typed_value] * and [typed_avalue] were instances of the same general type [g_typed_value], * but then we removed this general type because it proved to be a bad idea. *) - let rec typed_value_to_string (env : fmt_env) (v : typed_value) : string = + let rec typed_value_to_string (meta : Meta.meta) (env : fmt_env) (v : typed_value) : string = match v.value with | VLiteral cv -> literal_to_string cv | VAdt av -> ( let field_values = - List.map (typed_value_to_string env) av.field_values + List.map (typed_value_to_string meta env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -82,28 +83,28 @@ module Values = struct | TArray, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" - | _ -> raise (Failure ("Inconsistent value: " ^ show_typed_value v)) + | _ -> craise meta ("Inconsistent value: " ^ show_typed_value v) ) - | _ -> raise (Failure "Inconsistent typed value")) + | _ -> craise meta "Inconsistent typed value") | VBottom -> "⊥ : " ^ ty_to_string env v.ty - | VBorrow bc -> borrow_content_to_string env bc - | VLoan lc -> loan_content_to_string env lc + | VBorrow bc -> borrow_content_to_string meta env bc + | VLoan lc -> loan_content_to_string meta env lc | VSymbolic s -> symbolic_value_to_string env s - and borrow_content_to_string (env : fmt_env) (bc : borrow_content) : string = + and borrow_content_to_string (meta : Meta.meta) (env : fmt_env) (bc : borrow_content) : string = match bc with | VSharedBorrow bid -> "shared_borrow@" ^ BorrowId.to_string bid | VMutBorrow (bid, tv) -> "mut_borrow@" ^ BorrowId.to_string bid ^ " (" - ^ typed_value_to_string env tv + ^ typed_value_to_string meta env tv ^ ")" | VReservedMutBorrow bid -> "reserved_borrow@" ^ BorrowId.to_string bid - and loan_content_to_string (env : fmt_env) (lc : loan_content) : string = + and loan_content_to_string (meta : Meta.meta) (env : fmt_env) (lc : loan_content) : string = match lc with | VSharedLoan (loans, v) -> let loans = BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string env v ^ ")" + "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string meta env v ^ ")" | VMutLoan bid -> "ml@" ^ BorrowId.to_string bid let abstract_shared_borrow_to_string (env : fmt_env) @@ -141,11 +142,11 @@ module Values = struct | AEndedProjBorrows _mv -> "_" | AIgnoredProjBorrows -> "_" - let rec typed_avalue_to_string (env : fmt_env) (v : typed_avalue) : string = + let rec typed_avalue_to_string (meta : Meta.meta) (env : fmt_env) (v : typed_avalue) : string = match v.value with | AAdt av -> ( let field_values = - List.map (typed_avalue_to_string env) av.field_values + List.map (typed_avalue_to_string meta env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -177,75 +178,75 @@ module Values = struct (* Assumed type *) match (aty, field_values) with | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" - | _ -> raise (Failure "Inconsistent value")) - | _ -> raise (Failure "Inconsistent typed value")) + | _ -> craise meta "Inconsistent value") + | _ -> craise meta "Inconsistent typed value") | ABottom -> "⊥ : " ^ ty_to_string env v.ty - | ABorrow bc -> aborrow_content_to_string env bc - | ALoan lc -> aloan_content_to_string env lc + | ABorrow bc -> aborrow_content_to_string meta env bc + | ALoan lc -> aloan_content_to_string meta env lc | ASymbolic s -> aproj_to_string env s | AIgnored -> "_" - and aloan_content_to_string (env : fmt_env) (lc : aloan_content) : string = + and aloan_content_to_string (meta : Meta.meta) (env : fmt_env) (lc : aloan_content) : string = match lc with | AMutLoan (bid, av) -> "@mut_loan(" ^ BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string env av + ^ typed_avalue_to_string meta env av ^ ")" | ASharedLoan (loans, v, av) -> let loans = BorrowId.Set.to_string None loans in "@shared_loan(" ^ loans ^ ", " - ^ typed_value_to_string env v + ^ typed_value_to_string meta env v ^ ", " - ^ typed_avalue_to_string env av + ^ typed_avalue_to_string meta env av ^ ")" | AEndedMutLoan ml -> "@ended_mut_loan{" - ^ typed_avalue_to_string env ml.child + ^ typed_avalue_to_string meta env ml.child ^ "; " - ^ typed_avalue_to_string env ml.given_back + ^ typed_avalue_to_string meta env ml.given_back ^ " }" | AEndedSharedLoan (v, av) -> "@ended_shared_loan(" - ^ typed_value_to_string env v + ^ typed_value_to_string meta env v ^ ", " - ^ typed_avalue_to_string env av + ^ typed_avalue_to_string meta env av ^ ")" | AIgnoredMutLoan (opt_bid, av) -> "@ignored_mut_loan(" ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string env av + ^ typed_avalue_to_string meta env av ^ ")" | AEndedIgnoredMutLoan ml -> "@ended_ignored_mut_loan{ " - ^ typed_avalue_to_string env ml.child + ^ typed_avalue_to_string meta env ml.child ^ "; " - ^ typed_avalue_to_string env ml.given_back + ^ typed_avalue_to_string meta env ml.given_back ^ "}" | AIgnoredSharedLoan sl -> - "@ignored_shared_loan(" ^ typed_avalue_to_string env sl ^ ")" + "@ignored_shared_loan(" ^ typed_avalue_to_string meta env sl ^ ")" - and aborrow_content_to_string (env : fmt_env) (bc : aborrow_content) : string + and aborrow_content_to_string (meta : Meta.meta) (env : fmt_env) (bc : aborrow_content) : string = match bc with | AMutBorrow (bid, av) -> "mb@" ^ BorrowId.to_string bid ^ " (" - ^ typed_avalue_to_string env av + ^ typed_avalue_to_string meta env av ^ ")" | ASharedBorrow bid -> "sb@" ^ BorrowId.to_string bid | AIgnoredMutBorrow (opt_bid, av) -> "@ignored_mut_borrow(" ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string env av + ^ typed_avalue_to_string meta env av ^ ")" | AEndedMutBorrow (_mv, child) -> - "@ended_mut_borrow(" ^ typed_avalue_to_string env child ^ ")" + "@ended_mut_borrow(" ^ typed_avalue_to_string meta env child ^ ")" | AEndedIgnoredMutBorrow { child; given_back; given_back_meta = _ } -> "@ended_ignored_mut_borrow{ " - ^ typed_avalue_to_string env child + ^ typed_avalue_to_string meta env child ^ "; " - ^ typed_avalue_to_string env given_back + ^ typed_avalue_to_string meta env given_back ^ ")" | AEndedSharedBorrow -> "@ended_shared_borrow" | AProjSharedBorrow sb -> @@ -275,11 +276,11 @@ module Values = struct ^ ")" | Identity -> "Identity" - let abs_to_string (env : fmt_env) (verbose : bool) (indent : string) + let abs_to_string (meta : Meta.meta) (env : fmt_env) (verbose : bool) (indent : string) (indent_incr : string) (abs : abs) : string = let indent2 = indent ^ indent_incr in let avs = - List.map (fun av -> indent2 ^ typed_avalue_to_string env av) abs.avalues + List.map (fun av -> indent2 ^ typed_avalue_to_string meta env av) abs.avalues in let avs = String.concat ",\n" avs in let kind = @@ -322,7 +323,7 @@ module Contexts = struct | BVar b -> var_binder_to_string env b | BDummy bid -> dummy_var_id_to_string bid - let env_elem_to_string (env : fmt_env) (verbose : bool) + let env_elem_to_string (meta : Meta.meta) (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) (ev : env_elem) : string = match ev with @@ -331,17 +332,17 @@ module Contexts = struct let ty = if with_var_types then " : " ^ ty_to_string env tv.ty else "" in - indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string env tv ^ " ;" - | EAbs abs -> abs_to_string env verbose indent indent_incr abs - | EFrame -> raise (Failure "Can't print a Frame element") + indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string meta env tv ^ " ;" + | EAbs abs -> abs_to_string meta env verbose indent indent_incr abs + | EFrame -> craise meta "Can't print a Frame element" - let opt_env_elem_to_string (env : fmt_env) (verbose : bool) + let opt_env_elem_to_string (meta : Meta.meta) (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) (ev : env_elem option) : string = match ev with | None -> indent ^ "..." | Some ev -> - env_elem_to_string env verbose with_var_types indent indent_incr ev + env_elem_to_string meta env verbose with_var_types indent indent_incr ev (** Filters "dummy" bindings from an environment, to gain space and clarity/ See [env_to_string]. *) @@ -378,7 +379,7 @@ module Contexts = struct "..." to gain space and clarity. [with_var_types]: if true, print the type of the variables *) - let env_to_string (filter : bool) (fmt_env : fmt_env) (verbose : bool) + let env_to_string (meta : Meta.meta) (filter : bool) (fmt_env : fmt_env) (verbose : bool) (with_var_types : bool) (env : env) : string = let env = if filter then filter_env env else List.map (fun ev -> Some ev) env @@ -387,7 +388,7 @@ module Contexts = struct ^ String.concat "\n" (List.map (fun ev -> - opt_env_elem_to_string fmt_env verbose with_var_types " " " " ev) + opt_env_elem_to_string meta fmt_env verbose with_var_types " " " " ev) env) ^ "\n}" @@ -467,7 +468,7 @@ module Contexts = struct let frames = split_aux [] [] env in frames - let eval_ctx_to_string_gen (verbose : bool) (filter : bool) + let eval_ctx_to_string_gen (meta : Meta.meta) (verbose : bool) (filter : bool) (with_var_types : bool) (ctx : eval_ctx) : string = let fmt_env = eval_ctx_to_fmt_env ctx in let ended_regions = RegionId.Set.to_string None ctx.ended_regions in @@ -485,24 +486,24 @@ module Contexts = struct | EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 | EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 | EAbs _ -> num_abs := !num_abs + 1 - | _ -> raise (Failure "Unreachable")) + | _ -> craise meta "Unreachable") f; "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " ^ string_of_int !num_bindings ^ "\n- dummy bindings: " ^ string_of_int !num_dummies ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" - ^ env_to_string filter fmt_env verbose with_var_types f + ^ env_to_string meta filter fmt_env verbose with_var_types f ^ "\n") frames in "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames ^ " frame(s)\n" ^ String.concat "" frames - let eval_ctx_to_string (ctx : eval_ctx) : string = - eval_ctx_to_string_gen false true true ctx + let eval_ctx_to_string (meta : Meta.meta) (ctx : eval_ctx) : string = + eval_ctx_to_string_gen meta false true true ctx - let eval_ctx_to_string_no_filter (ctx : eval_ctx) : string = - eval_ctx_to_string_gen false false true ctx + let eval_ctx_to_string_no_filter (meta : Meta.meta) (ctx : eval_ctx) : string = + eval_ctx_to_string_gen meta false false true ctx end (** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) @@ -540,22 +541,22 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in trait_instance_id_to_string env x - let borrow_content_to_string (ctx : eval_ctx) (bc : borrow_content) : string = + let borrow_content_to_string (meta : Meta.meta) (ctx : eval_ctx) (bc : borrow_content) : string = let env = eval_ctx_to_fmt_env ctx in - borrow_content_to_string env bc + borrow_content_to_string meta env bc - let loan_content_to_string (ctx : eval_ctx) (lc : loan_content) : string = + let loan_content_to_string (meta : Meta.meta) (ctx : eval_ctx) (lc : loan_content) : string = let env = eval_ctx_to_fmt_env ctx in - loan_content_to_string env lc + loan_content_to_string meta env lc - let aborrow_content_to_string (ctx : eval_ctx) (bc : aborrow_content) : string + let aborrow_content_to_string (meta : Meta.meta) (ctx : eval_ctx) (bc : aborrow_content) : string = let env = eval_ctx_to_fmt_env ctx in - aborrow_content_to_string env bc + aborrow_content_to_string meta env bc - let aloan_content_to_string (ctx : eval_ctx) (lc : aloan_content) : string = + let aloan_content_to_string (meta : Meta.meta) (ctx : eval_ctx) (lc : aloan_content) : string = let env = eval_ctx_to_fmt_env ctx in - aloan_content_to_string env lc + aloan_content_to_string meta env lc let aproj_to_string (ctx : eval_ctx) (p : aproj) : string = let env = eval_ctx_to_fmt_env ctx in @@ -565,13 +566,13 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in symbolic_value_to_string env sv - let typed_value_to_string (ctx : eval_ctx) (v : typed_value) : string = + let typed_value_to_string (meta : Meta.meta) (ctx : eval_ctx) (v : typed_value) : string = let env = eval_ctx_to_fmt_env ctx in - typed_value_to_string env v + typed_value_to_string meta env v - let typed_avalue_to_string (ctx : eval_ctx) (v : typed_avalue) : string = + let typed_avalue_to_string (meta : Meta.meta) (ctx : eval_ctx) (v : typed_avalue) : string = let env = eval_ctx_to_fmt_env ctx in - typed_avalue_to_string env v + typed_avalue_to_string meta env v let place_to_string (ctx : eval_ctx) (op : place) : string = let env = eval_ctx_to_fmt_env ctx in @@ -612,13 +613,13 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in trait_impl_to_string env " " " " timpl - let env_elem_to_string (ctx : eval_ctx) (indent : string) + let env_elem_to_string (meta : Meta.meta) (ctx : eval_ctx) (indent : string) (indent_incr : string) (ev : env_elem) : string = let env = eval_ctx_to_fmt_env ctx in - env_elem_to_string env false true indent indent_incr ev + env_elem_to_string meta env false true indent indent_incr ev - let abs_to_string (ctx : eval_ctx) (indent : string) (indent_incr : string) + let abs_to_string (meta : Meta.meta) (ctx : eval_ctx) (indent : string) (indent_incr : string) (abs : abs) : string = let env = eval_ctx_to_fmt_env ctx in - abs_to_string env false indent indent_incr abs + abs_to_string meta env false indent indent_incr abs end diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 00a431a0..618a8afc 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -2,6 +2,7 @@ open Pure open PureUtils +open Errors (** The formatting context for pure definitions uses non-pure definitions to lookup names. The main reason is that when building the pure definitions @@ -293,7 +294,7 @@ let mplace_to_string (env : fmt_env) (p : mplace) : string = let name = name ^ "^" ^ E.VarId.to_string p.var_id ^ "llbc" in mprojection_to_string env name p.projection -let adt_variant_to_string (env : fmt_env) (adt_id : type_id) +let adt_variant_to_string (meta : Meta.meta) (env : fmt_env) (adt_id : type_id) (variant_id : VariantId.id option) : string = match adt_id with | TTuple -> "Tuple" @@ -307,29 +308,29 @@ let adt_variant_to_string (env : fmt_env) (adt_id : type_id) match aty with | TState | TArray | TSlice | TStr | TRawPtr _ -> (* Those types are opaque: we can't get there *) - raise (Failure "Unreachable") + craise meta "Unreachable" | TResult -> let variant_id = Option.get variant_id in if variant_id = result_return_id then "@Result::Return" else if variant_id = result_fail_id then "@Result::Fail" else - raise (Failure "Unreachable: improper variant id for result type") + craise meta "Unreachable: improper variant id for result type" | TError -> let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" - else raise (Failure "Unreachable: improper variant id for error type") + else craise meta "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then "@Fuel::Zero" else if variant_id = fuel_succ_id then "@Fuel::Succ" - else raise (Failure "Unreachable: improper variant id for fuel type")) + else craise meta "Unreachable: improper variant id for fuel type") -let adt_field_to_string (env : fmt_env) (adt_id : type_id) +let adt_field_to_string (meta : Meta.meta) (env : fmt_env) (adt_id : type_id) (field_id : FieldId.id) : string = match adt_id with | TTuple -> - raise (Failure "Unreachable") + craise meta "Unreachable" (* Tuples don't use the opaque field id for the field indices, but [int] *) | TAdtId def_id -> ( (* "Regular" ADT *) @@ -342,15 +343,15 @@ let adt_field_to_string (env : fmt_env) (adt_id : type_id) match aty with | TState | TFuel | TArray | TSlice | TStr -> (* Opaque types: we can't get there *) - raise (Failure "Unreachable") + craise meta "Unreachable" | TResult | TError | TRawPtr _ -> (* Enumerations: we can't get there *) - raise (Failure "Unreachable")) + craise meta "Unreachable") (** TODO: we don't need a general function anymore (it is now only used for patterns) *) -let adt_g_value_to_string (env : fmt_env) (value_to_string : 'v -> string) +let adt_g_value_to_string (meta : Meta.meta) (env : fmt_env) (value_to_string : 'v -> string) (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in @@ -385,50 +386,50 @@ let adt_g_value_to_string (env : fmt_env) (value_to_string : 'v -> string) match aty with | TState | TRawPtr _ -> (* This type is opaque: we can't get there *) - raise (Failure "Unreachable") + craise meta "Unreachable" | TResult -> let variant_id = Option.get variant_id in if variant_id = result_return_id then match field_values with | [ v ] -> "@Result::Return " ^ v - | _ -> raise (Failure "Result::Return takes exactly one value") + | _ -> craise meta "Result::Return takes exactly one value" else if variant_id = result_fail_id then match field_values with | [ v ] -> "@Result::Fail " ^ v - | _ -> raise (Failure "Result::Fail takes exactly one value") + | _ -> craise meta "Result::Fail takes exactly one value" else - raise (Failure "Unreachable: improper variant id for result type") + craise meta "Unreachable: improper variant id for result type" | TError -> - assert (field_values = []); + cassert (field_values = []) meta "TODO: error message"; let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" - else raise (Failure "Unreachable: improper variant id for error type") + else craise meta "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then ( - assert (field_values = []); + cassert (field_values = []) meta "TODO: error message"; "@Fuel::Zero") else if variant_id = fuel_succ_id then match field_values with | [ v ] -> "@Fuel::Succ " ^ v - | _ -> raise (Failure "@Fuel::Succ takes exactly one value") - else raise (Failure "Unreachable: improper variant id for fuel type") + | _ -> craise meta "@Fuel::Succ takes exactly one value" + else craise meta "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr -> - assert (variant_id = None); + cassert (variant_id = None) meta "TODO: error message"; let field_values = List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values in let id = assumed_ty_to_string aty in id ^ " [" ^ String.concat "; " field_values ^ "]") | _ -> - raise - (Failure + craise + meta ("Inconsistently typed value: expected ADT type but found:" ^ "\n- ty: " ^ ty_to_string env false ty ^ "\n- variant_id: " - ^ Print.option_to_string VariantId.to_string variant_id)) + ^ Print.option_to_string VariantId.to_string variant_id) -let rec typed_pattern_to_string (env : fmt_env) (v : typed_pattern) : string = +let rec typed_pattern_to_string (meta : Meta.meta) (env : fmt_env) (v : typed_pattern) : string = match v.value with | PatConstant cv -> literal_to_string cv | PatVar (v, None) -> var_to_string env v @@ -439,8 +440,8 @@ let rec typed_pattern_to_string (env : fmt_env) (v : typed_pattern) : string = ^ ")" | PatDummy -> "_" | PatAdt av -> - adt_g_value_to_string env - (typed_pattern_to_string env) + adt_g_value_to_string meta env + (typed_pattern_to_string meta env) av.variant_id av.field_values v.ty let fun_sig_to_string (env : fmt_env) (sg : fun_sig) : string = @@ -521,7 +522,7 @@ let fun_or_op_id_to_string (env : fmt_env) (fun_id : fun_or_op_id) : string = binop_to_string binop ^ "<" ^ integer_type_to_string int_ty ^ ">" (** [inside]: controls the introduction of parentheses *) -let rec texpression_to_string (env : fmt_env) (inside : bool) (indent : string) +let rec texpression_to_string (metadata : Meta.meta) (env : fmt_env) (inside : bool) (indent : string) (indent_incr : string) (e : texpression) : string = match e.e with | Var var_id -> var_id_to_string env var_id @@ -531,22 +532,22 @@ let rec texpression_to_string (env : fmt_env) (inside : bool) (indent : string) (* Recursively destruct the app, to have a pair (app, arguments list) *) let app, args = destruct_apps e in (* Convert to string *) - app_to_string env inside indent indent_incr app args + app_to_string metadata env inside indent indent_incr app args | Lambda _ -> let xl, e = destruct_lambdas e in - let e = lambda_to_string env indent indent_incr xl e in + let e = lambda_to_string metadata env indent indent_incr xl e in if inside then "(" ^ e ^ ")" else e | Qualif _ -> (* Qualifier without arguments *) - app_to_string env inside indent indent_incr e [] + app_to_string metadata env inside indent indent_incr e [] | Let (monadic, lv, re, e) -> - let e = let_to_string env indent indent_incr monadic lv re e in + let e = let_to_string metadata env indent indent_incr monadic lv re e in if inside then "(" ^ e ^ ")" else e | Switch (scrutinee, body) -> - let e = switch_to_string env indent indent_incr scrutinee body in + let e = switch_to_string metadata env indent indent_incr scrutinee body in if inside then "(" ^ e ^ ")" else e | Loop loop -> - let e = loop_to_string env indent indent_incr loop in + let e = loop_to_string metadata env indent indent_incr loop in if inside then "(" ^ e ^ ")" else e | StructUpdate supd -> ( let s = @@ -565,7 +566,7 @@ let rec texpression_to_string (env : fmt_env) (inside : bool) (indent : string) (fun (fid, fe) -> let field = FieldId.nth field_names fid in let fe = - texpression_to_string env false indent2 indent_incr fe + texpression_to_string metadata env false indent2 indent_incr fe in "\n" ^ indent1 ^ field ^ " := " ^ fe ^ ";") supd.updates @@ -576,21 +577,21 @@ let rec texpression_to_string (env : fmt_env) (inside : bool) (indent : string) let fields = List.map (fun (_, fe) -> - texpression_to_string env false indent2 indent_incr fe) + texpression_to_string metadata env false indent2 indent_incr fe) supd.updates in "[ " ^ String.concat ", " fields ^ " ]" - | _ -> raise (Failure "Unexpected")) + | _ -> craise metadata "Unexpected") | Meta (meta, e) -> ( - let meta_s = emeta_to_string env meta in - let e = texpression_to_string env inside indent indent_incr e in + let meta_s = emeta_to_string metadata env meta in + let e = texpression_to_string metadata env inside indent indent_incr e in match meta with | Assignment _ | SymbolicAssignments _ | SymbolicPlaces _ | Tag _ -> let e = meta_s ^ "\n" ^ indent ^ e in if inside then "(" ^ e ^ ")" else e | MPlace _ -> "(" ^ meta_s ^ " " ^ e ^ ")") -and app_to_string (env : fmt_env) (inside : bool) (indent : string) +and app_to_string (meta : Meta.meta) (env : fmt_env) (inside : bool) (indent : string) (indent_incr : string) (app : texpression) (args : texpression list) : string = (* There are two possibilities: either the [app] is an instantiated, @@ -610,13 +611,13 @@ and app_to_string (env : fmt_env) (inside : bool) (indent : string) (global_decl_id_to_string env global_id, generics) | AdtCons adt_cons_id -> let variant_s = - adt_variant_to_string env adt_cons_id.adt_id + adt_variant_to_string meta env adt_cons_id.adt_id adt_cons_id.variant_id in (ConstStrings.constructor_prefix ^ variant_s, []) | Proj { adt_id; field_id } -> - let adt_s = adt_variant_to_string env adt_id None in - let field_s = adt_field_to_string env adt_id field_id in + let adt_s = adt_variant_to_string meta env adt_id None in + let field_s = adt_field_to_string meta env adt_id field_id in (* Adopting an F*-like syntax *) (ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s, []) | TraitConst (trait_ref, const_name) -> @@ -626,7 +627,7 @@ and app_to_string (env : fmt_env) (inside : bool) (indent : string) | _ -> (* "Regular" expression case *) let inside = args <> [] || (args = [] && inside) in - (texpression_to_string env inside indent indent_incr app, []) + (texpression_to_string meta env inside indent indent_incr app, []) in (* Convert the arguments. * The arguments are expressions, so indentation might get weird... (though @@ -634,7 +635,7 @@ and app_to_string (env : fmt_env) (inside : bool) (indent : string) let arg_to_string = let inside = true in let indent1 = indent ^ indent_incr in - texpression_to_string env inside indent1 indent_incr + texpression_to_string meta env inside indent1 indent_incr in let args = List.map arg_to_string args in let all_args = List.append generics args in @@ -645,31 +646,31 @@ and app_to_string (env : fmt_env) (inside : bool) (indent : string) (* Add parentheses *) if all_args <> [] && inside then "(" ^ e ^ ")" else e -and lambda_to_string (env : fmt_env) (indent : string) (indent_incr : string) +and lambda_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_incr : string) (xl : typed_pattern list) (e : texpression) : string = - let xl = List.map (typed_pattern_to_string env) xl in - let e = texpression_to_string env false indent indent_incr e in + let xl = List.map (typed_pattern_to_string meta env) xl in + let e = texpression_to_string meta env false indent indent_incr e in "λ " ^ String.concat " " xl ^ ". " ^ e -and let_to_string (env : fmt_env) (indent : string) (indent_incr : string) +and let_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_incr : string) (monadic : bool) (lv : typed_pattern) (re : texpression) (e : texpression) : string = let indent1 = indent ^ indent_incr in let inside = false in - let re = texpression_to_string env inside indent1 indent_incr re in - let e = texpression_to_string env inside indent indent_incr e in - let lv = typed_pattern_to_string env lv in + let re = texpression_to_string meta env inside indent1 indent_incr re in + let e = texpression_to_string meta env inside indent indent_incr e in + let lv = typed_pattern_to_string meta env lv in if monadic then lv ^ " <-- " ^ re ^ ";\n" ^ indent ^ e else "let " ^ lv ^ " = " ^ re ^ " in\n" ^ indent ^ e -and switch_to_string (env : fmt_env) (indent : string) (indent_incr : string) +and switch_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_incr : string) (scrutinee : texpression) (body : switch_body) : string = let indent1 = indent ^ indent_incr in (* Printing can mess up on the scrutinee, because it is an expression - but * in most situations it will be a value or a function call, so it should be * ok*) - let scrut = texpression_to_string env true indent1 indent_incr scrutinee in - let e_to_string = texpression_to_string env false indent1 indent_incr in + let scrut = texpression_to_string meta env true indent1 indent_incr scrutinee in + let e_to_string = texpression_to_string meta env false indent1 indent_incr in match body with | If (e_true, e_false) -> let e_true = e_to_string e_true in @@ -678,13 +679,13 @@ and switch_to_string (env : fmt_env) (indent : string) (indent_incr : string) ^ indent ^ "else\n" ^ indent1 ^ e_false | Match branches -> let branch_to_string (b : match_branch) : string = - let pat = typed_pattern_to_string env b.pat in + let pat = typed_pattern_to_string meta env b.pat in indent ^ "| " ^ pat ^ " ->\n" ^ indent1 ^ e_to_string b.branch in let branches = List.map branch_to_string branches in "match " ^ scrut ^ " with\n" ^ String.concat "\n" branches -and loop_to_string (env : fmt_env) (indent : string) (indent_incr : string) +and loop_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_incr : string) (loop : loop) : string = let indent1 = indent ^ indent_incr in let indent2 = indent1 ^ indent_incr in @@ -695,17 +696,17 @@ and loop_to_string (env : fmt_env) (indent : string) (indent_incr : string) in let output_ty = "output_ty: " ^ ty_to_string env false loop.output_ty in let fun_end = - texpression_to_string env false indent2 indent_incr loop.fun_end + texpression_to_string meta env false indent2 indent_incr loop.fun_end in let loop_body = - texpression_to_string env false indent2 indent_incr loop.loop_body + texpression_to_string meta env false indent2 indent_incr loop.loop_body in "loop {\n" ^ indent1 ^ loop_inputs ^ "\n" ^ indent1 ^ output_ty ^ "\n" ^ indent1 ^ "fun_end: {\n" ^ indent2 ^ fun_end ^ "\n" ^ indent1 ^ "}\n" ^ indent1 ^ "loop_body: {\n" ^ indent2 ^ loop_body ^ "\n" ^ indent1 ^ "}\n" ^ indent ^ "}" -and emeta_to_string (env : fmt_env) (meta : emeta) : string = +and emeta_to_string (metadata : Meta.meta) (env : fmt_env) (meta : emeta) : string = let meta = match meta with | Assignment (lp, rv, rp) -> @@ -715,14 +716,14 @@ and emeta_to_string (env : fmt_env) (meta : emeta) : string = | Some rp -> " [@src=" ^ mplace_to_string env rp ^ "]" in "@assign(" ^ mplace_to_string env lp ^ " := " - ^ texpression_to_string env false "" "" rv + ^ texpression_to_string metadata env false "" "" rv ^ rp ^ ")" | SymbolicAssignments info -> let infos = List.map (fun (var_id, rv) -> VarId.to_string var_id ^ " == " - ^ texpression_to_string env false "" "" rv) + ^ texpression_to_string metadata env false "" "" rv) info in let infos = String.concat ", " infos in @@ -755,5 +756,5 @@ let fun_decl_to_string (env : fmt_env) (def : fun_decl) : string = if inputs = [] then indent else " fun " ^ String.concat " " inputs ^ " ->\n" ^ indent in - let body = texpression_to_string env inside indent indent body.body in + let body = texpression_to_string def.meta env inside indent indent body.body in "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index a1f6ce33..2fb33036 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -3,6 +3,7 @@ open Pure open PureUtils open TranslateCore +open Errors (** The local logger *) let log = Logging.pure_micro_passes_log @@ -221,7 +222,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = (* Register a variable for constraints propagation - used when an variable is * introduced (left-hand side of a left binding) *) let register_var (ctx : pn_ctx) (v : var) : pn_ctx = - assert (not (VarId.Map.mem v.id ctx.pure_vars)); + cassert (not (VarId.Map.mem v.id ctx.pure_vars)) def.meta "TODO: error message"; match v.basename with | None -> ctx | Some name -> @@ -610,7 +611,7 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = | App _ -> ( let app, args = destruct_apps e in let ignore () = - mk_apps + mk_apps def.meta (self#visit_texpression env app) (List.map (self#visit_texpression env) args) in @@ -755,7 +756,7 @@ let simplify_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = else if variant_id = result_fail_id then (* Fail case *) self#visit_expression env rv.e - else raise (Failure "Unexpected") + else craise def.meta "Unexpected" | App _ -> (* This might be the tuple case *) if not monadic then @@ -910,7 +911,7 @@ let inline_useless_var_reassignments (ctx : trans_ctx) ~(inline_named : bool) } ) -> (* Second case: we deconstruct a structure with one field that we will extract as tuple. *) - let adt_id, _ = PureUtils.ty_as_adt re.ty in + let adt_id, _ = PureUtils.ty_as_adt def.meta re.ty in (* Update the rhs (we may perform substitutions inside, and it is * better to do them *before* we inline it *) let re = self#visit_texpression env re in @@ -1091,7 +1092,7 @@ let filter_useless (_ctx : trans_ctx) (def : fun_decl) : fun_decl = f y ]} *) -let simplify_let_then_return _ctx def = +let simplify_let_then_return _ctx (def : fun_decl) = (* Match a pattern and an expression: evaluates to [true] if the expression is actually exactly the pattern *) let rec match_pattern_and_expr (pat : typed_pattern) (e : texpression) : bool @@ -1139,7 +1140,7 @@ let simplify_let_then_return _ctx def = (* The first let-binding is monadic *) match opt_destruct_ret next_e with | Some e -> - if match_pattern_and_expr lv e then rv.e else not_simpl_e + if match_pattern_and_expr def.meta lv e then rv.e else not_simpl_e | None -> not_simpl_e else (* The first let-binding is not monadic *) @@ -1147,7 +1148,7 @@ let simplify_let_then_return _ctx def = | Some e -> if match_pattern_and_expr lv e then (* We need to wrap the right-value in a ret *) - (mk_result_return_texpression rv).e + (mk_result_return_texpression def.meta rv).e else not_simpl_e | None -> if match_pattern_and_expr lv next_e then rv.e else not_simpl_e @@ -1197,13 +1198,13 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = in let fields = match adt_decl.kind with - | Enum _ | Opaque -> raise (Failure "Unreachable") + | Enum _ | Opaque -> craise def.meta "Unreachable" | Struct fields -> fields in let num_fields = List.length fields in (* In order to simplify, there must be as many arguments as * there are fields *) - assert (num_fields > 0); + cassert (num_fields > 0) def.meta "The number of fields is not > 0"; if num_fields = List.length args then (* We now need to check that all the arguments are of the form: * [x.field] for some variable [x], and where the projection @@ -1239,10 +1240,10 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = if List.for_all (fun (_, y) -> y = x) end_args then ( (* We can substitute *) (* Sanity check: all types correct *) - assert ( + cassert ( List.for_all (fun (generics1, _) -> generics1 = generics) - args); + args) def.meta "All types are not correct"; { e with e = Var x }) else super#visit_texpression env e else super#visit_texpression env e @@ -1397,7 +1398,7 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : { fwd_info; effect_info = loop_fwd_effect_info; ignore_output } in - assert (fun_sig_info_is_wf loop_fwd_sig_info); + cassert (fun_sig_info_is_wf loop_fwd_sig_info) def.meta "TODO: error message"; let inputs_tys = let fuel = if !Config.use_fuel then [ mk_fuel_ty ] else [] in @@ -1437,9 +1438,9 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : (* Introduce the forward input state *) let fwd_state_var, fwd_state_lvs = - assert ( + cassert ( loop_fwd_effect_info.stateful - = Option.is_some loop.input_state); + = Option.is_some loop.input_state) def.meta "TODO: error message"; match loop.input_state with | None -> ([], []) | Some input_state -> @@ -1476,7 +1477,7 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : match fuel_vars with | None -> loop.loop_body | Some (fuel0, fuel) -> - SymbolicToPure.wrap_in_match_fuel fuel0 fuel loop.loop_body + SymbolicToPure.wrap_in_match_fuel def.meta fuel0 fuel loop.loop_body in let loop_body = { inputs; inputs_lvs; body = loop_body } in @@ -1569,9 +1570,9 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = match aid with | BoxNew -> let arg, args = Collections.List.pop args in - mk_apps arg args + mk_apps def.meta arg args | BoxFree -> - assert (args = []); + cassert (args = []) def.meta "TODO: error message"; mk_unit_rvalue | SliceIndexShared | SliceIndexMut | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut @@ -1765,8 +1766,8 @@ let unfold_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = *) (* TODO: this information should be computed in SymbolicToPure and * store in an enum ("monadic" should be an enum, not a bool). *) - let re_ty = Option.get (opt_destruct_result re.ty) in - assert (lv.ty = re_ty); + let re_ty = Option.get (opt_destruct_result def.meta re.ty) in + cassert (lv.ty = re_ty) def.meta "TODO: error message"; let err_vid = fresh_id () in let err_var : var = { @@ -1778,7 +1779,7 @@ let unfold_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = let err_pat = mk_typed_pattern_from_var err_var None in let fail_pat = mk_result_fail_pattern err_pat.value lv.ty in let err_v = mk_texpression_from_var err_var in - let fail_value = mk_result_fail_texpression err_v e.ty in + let fail_value = mk_result_fail_texpression def.meta err_v e.ty in let fail_branch = { pat = fail_pat; branch = fail_value } in let success_pat = mk_result_return_pattern lv in let success_branch = { pat = success_pat; branch = e } in @@ -1980,7 +1981,7 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : (List.concat (List.map (fun { f; loops } -> [ f :: loops ]) transl)) in let subgroups = ReorderDecls.group_reorder_fun_decls all_decls in - +(* TODO meta or not meta ? *) log#ldebug (lazy ("filter_loop_inputs: all_decls:\n\n" @@ -2020,7 +2021,7 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : ^ String.concat ", " (List.map (var_to_string ctx) inputs_prefix) ^ "\n")); let inputs_set = VarId.Set.of_list (List.map var_get_id inputs_prefix) in - assert (Option.is_some decl.loop_id); + cassert (Option.is_some decl.loop_id) decl.meta "TODO: error message"; let fun_id = (E.FRegular decl.def_id, decl.loop_id) in @@ -2172,7 +2173,7 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : in let fwd_info = { fwd_info; effect_info; ignore_output } in - assert (fun_sig_info_is_wf fwd_info); + cassert (fun_sig_info_is_wf fwd_info) decl.meta "TODO: error message"; let signature = { generics; @@ -2238,17 +2239,17 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : in (* Rebuild *) - mk_apps e_app args) + mk_apps decl.meta e_app args) | _ -> let e_app = self#visit_texpression env e_app in let args = List.map (self#visit_texpression env) args in - mk_apps e_app args) + mk_apps decl.meta e_app args) | _ -> let e_app = self#visit_texpression env e_app in let args = List.map (self#visit_texpression env) args in - mk_apps e_app args) + mk_apps decl.meta e_app args) | _ -> super#visit_texpression env e end in diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index fc94fa4c..6bc11a7c 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -2,21 +2,22 @@ open Pure open PureUtils +open Errors (** Utility function, used for type checking. This function should only be used for "regular" ADTs, where the number of fields is fixed: it shouldn't be used for arrays, slices, etc. *) -let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) +let get_adt_field_types (meta : Meta.meta) (type_decls : type_decl TypeDeclId.Map.t) (type_id : type_id) (variant_id : VariantId.id option) (generics : generic_args) : ty list = match type_id with | TTuple -> (* Tuple *) - assert (generics.const_generics = []); - assert (generics.trait_refs = []); - assert (variant_id = None); + cassert (generics.const_generics = []) meta "TODO: error message"; + cassert (generics.trait_refs = []) meta "TODO: error message"; + cassert (variant_id = None) meta "TODO: error message"; generics.types | TAdtId def_id -> (* "Regular" ADT *) @@ -27,29 +28,29 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) match aty with | TState -> (* This type is opaque *) - raise (Failure "Unreachable: opaque type") + craise meta "Unreachable: opaque type" | TResult -> let ty = Collections.List.to_cons_nil generics.types in let variant_id = Option.get variant_id in if variant_id = result_return_id then [ ty ] else if variant_id = result_fail_id then [ mk_error_ty ] else - raise (Failure "Unreachable: improper variant id for result type") + craise meta "Unreachable: improper variant id for result type" | TError -> - assert (generics = empty_generic_args); + cassert (generics = empty_generic_args) meta "TODO: error message"; let variant_id = Option.get variant_id in - assert ( - variant_id = error_failure_id || variant_id = error_out_of_fuel_id); + cassert ( + variant_id = error_failure_id || variant_id = error_out_of_fuel_id) meta "TODO: error message"; [] | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then [] else if variant_id = fuel_succ_id then [ mk_fuel_ty ] - else raise (Failure "Unreachable: improper variant id for fuel type") + else craise meta "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr | TRawPtr _ -> (* Array: when not symbolic values (for instance, because of aggregates), the array expressions are introduced as struct updates *) - raise (Failure "Attempting to access the fields of an opaque type")) + craise meta "Attempting to access the fields of an opaque type") type tc_ctx = { type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) @@ -61,28 +62,28 @@ type tc_ctx = { (* TODO: add trait type constraints *) } -let check_literal (v : literal) (ty : literal_type) : unit = +let check_literal (meta : Meta.meta) (v : literal) (ty : literal_type) : unit = match (ty, v) with - | TInteger int_ty, VScalar sv -> assert (int_ty = sv.int_ty) + | TInteger int_ty, VScalar sv -> cassert (int_ty = sv.int_ty) meta "TODO: error message" | TBool, VBool _ | TChar, VChar _ -> () - | _ -> raise (Failure "Inconsistent type") + | _ -> craise meta "Inconsistent type" -let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = +let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = log#ldebug (lazy ("check_typed_pattern: " ^ show_typed_pattern v)); match v.value with | PatConstant cv -> - check_literal cv (ty_as_literal v.ty); + check_literal meta cv (ty_as_literal meta v.ty); ctx | PatDummy -> ctx | PatVar (var, _) -> - assert (var.ty = v.ty); + cassert (var.ty = v.ty) meta "TODO: error message"; let env = VarId.Map.add var.id var.ty ctx.env in { ctx with env } | PatAdt av -> (* Compute the field types *) - let type_id, generics = ty_as_adt v.ty in + let type_id, generics = ty_as_adt meta v.ty in let field_tys = - get_adt_field_types ctx.type_decls type_id av.variant_id generics + get_adt_field_types meta ctx.type_decls type_id av.variant_id generics in let check_value (ctx : tc_ctx) (ty : ty) (v : typed_pattern) : tc_ctx = if ty <> v.ty then ( @@ -90,8 +91,8 @@ let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = log#serror ("check_typed_pattern: not the same types:" ^ "\n- ty: " ^ show_ty ty ^ "\n- v.ty: " ^ show_ty v.ty); - raise (Failure "Inconsistent types")); - check_typed_pattern ctx v + craise meta "Inconsistent types"); + check_typed_pattern meta ctx v in (* Check the field types: check that the field patterns have the expected * types, and check that the field patterns themselves are well-typed *) @@ -100,7 +101,7 @@ let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = ctx (List.combine field_tys av.field_values) -let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = +let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : unit = match e.e with | Var var_id -> ( (* Lookup the variable - note that the variable may not be there, @@ -109,24 +110,24 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = * we use a locally nameless representation *) match VarId.Map.find_opt var_id ctx.env with | None -> () - | Some ty -> assert (ty = e.ty)) + | Some ty -> cassert (ty = e.ty) meta "TODO: error message") | CVar cg_id -> let ty = T.ConstGenericVarId.Map.find cg_id ctx.const_generics in - assert (ty = e.ty) - | Const cv -> check_literal cv (ty_as_literal e.ty) + cassert (ty = e.ty) meta "TODO: error message" + | Const cv -> check_literal meta cv (ty_as_literal meta e.ty) | App (app, arg) -> - let input_ty, output_ty = destruct_arrow app.ty in - assert (input_ty = arg.ty); - assert (output_ty = e.ty); - check_texpression ctx app; - check_texpression ctx arg + let input_ty, output_ty = destruct_arrow meta app.ty in + cassert (input_ty = arg.ty) meta "TODO: error message"; + cassert (output_ty = e.ty) meta "TODO: error message"; + check_texpression meta ctx app; + check_texpression meta ctx arg | Lambda (pat, body) -> - let pat_ty, body_ty = destruct_arrow e.ty in - assert (pat.ty = pat_ty); - assert (body.ty = body_ty); + let pat_ty, body_ty = destruct_arrow meta e.ty in + cassert (pat.ty = pat_ty) meta "TODO: error message"; + cassert (body.ty = body_ty) meta "TODO: error message"; (* Check the pattern and register the introduced variables at the same time *) - let ctx = check_typed_pattern ctx pat in - check_texpression ctx body + let ctx = check_typed_pattern meta ctx pat in + check_texpression meta ctx body | Qualif qualif -> ( match qualif.id with | FunOrOp _ -> () (* TODO *) @@ -135,83 +136,83 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = | Proj { adt_id = proj_adt_id; field_id } -> (* Note we can only project fields of structures (not enumerations) *) (* Deconstruct the projector type *) - let adt_ty, field_ty = destruct_arrow e.ty in - let adt_id, adt_generics = ty_as_adt adt_ty in + let adt_ty, field_ty = destruct_arrow meta e.ty in + let adt_id, adt_generics = ty_as_adt meta adt_ty in (* Check the ADT type *) - assert (adt_id = proj_adt_id); - assert (adt_generics = qualif.generics); + cassert (adt_id = proj_adt_id) meta "TODO: error message"; + cassert (adt_generics = qualif.generics) meta "TODO: error message"; (* Retrieve and check the expected field type *) let variant_id = None in let expected_field_tys = - get_adt_field_types ctx.type_decls proj_adt_id variant_id + get_adt_field_types meta ctx.type_decls proj_adt_id variant_id qualif.generics in let expected_field_ty = FieldId.nth expected_field_tys field_id in - assert (expected_field_ty = field_ty) + cassert (expected_field_ty = field_ty) meta "TODO: error message" | AdtCons id -> ( let expected_field_tys = - get_adt_field_types ctx.type_decls id.adt_id id.variant_id + get_adt_field_types meta ctx.type_decls id.adt_id id.variant_id qualif.generics in let field_tys, adt_ty = destruct_arrows e.ty in - assert (expected_field_tys = field_tys); + cassert (expected_field_tys = field_tys) meta "TODO: error message"; match adt_ty with | TAdt (type_id, generics) -> - assert (type_id = id.adt_id); - assert (generics = qualif.generics) - | _ -> raise (Failure "Unreachable"))) + cassert (type_id = id.adt_id) meta "TODO: error message"; + cassert (generics = qualif.generics) meta "TODO: error message" + | _ -> craise meta "Unreachable")) | Let (monadic, pat, re, e_next) -> - let expected_pat_ty = if monadic then destruct_result re.ty else re.ty in - assert (pat.ty = expected_pat_ty); - assert (e.ty = e_next.ty); + let expected_pat_ty = if monadic then destruct_result meta re.ty else re.ty in + cassert (pat.ty = expected_pat_ty) meta "TODO: error message"; + cassert (e.ty = e_next.ty) meta "TODO: error message"; (* Check the right-expression *) - check_texpression ctx re; + check_texpression meta ctx re; (* Check the pattern and register the introduced variables at the same time *) - let ctx = check_typed_pattern ctx pat in + let ctx = check_typed_pattern meta ctx pat in (* Check the next expression *) - check_texpression ctx e_next + check_texpression meta ctx e_next | Switch (scrut, switch_body) -> ( - check_texpression ctx scrut; + check_texpression meta ctx scrut; match switch_body with | If (e_then, e_else) -> - assert (scrut.ty = TLiteral TBool); - assert (e_then.ty = e.ty); - assert (e_else.ty = e.ty); - check_texpression ctx e_then; - check_texpression ctx e_else + cassert (scrut.ty = TLiteral TBool) meta "TODO: error message"; + cassert (e_then.ty = e.ty) meta "TODO: error message"; + cassert (e_else.ty = e.ty) meta "TODO: error message"; + check_texpression meta ctx e_then; + check_texpression meta ctx e_else | Match branches -> let check_branch (br : match_branch) : unit = - assert (br.pat.ty = scrut.ty); - let ctx = check_typed_pattern ctx br.pat in - check_texpression ctx br.branch + cassert (br.pat.ty = scrut.ty) meta "TODO: error message"; + let ctx = check_typed_pattern meta ctx br.pat in + check_texpression meta ctx br.branch in List.iter check_branch branches) | Loop loop -> - assert (loop.fun_end.ty = e.ty); - check_texpression ctx loop.fun_end; - check_texpression ctx loop.loop_body + cassert (loop.fun_end.ty = e.ty) meta "TODO: error message"; + check_texpression meta ctx loop.fun_end; + check_texpression meta ctx loop.loop_body | StructUpdate supd -> ( (* Check the init value *) (if Option.is_some supd.init then match VarId.Map.find_opt (Option.get supd.init) ctx.env with | None -> () - | Some ty -> assert (ty = e.ty)); + | Some ty -> cassert (ty = e.ty) meta "TODO: error message"); (* Check the fields *) (* Retrieve and check the expected field type *) - let adt_id, adt_generics = ty_as_adt e.ty in - assert (adt_id = supd.struct_id); + let adt_id, adt_generics = ty_as_adt meta e.ty in + cassert (adt_id = supd.struct_id) meta "TODO: error message"; (* The id can only be: a custom type decl or an array *) match adt_id with | TAdtId _ -> let variant_id = None in let expected_field_tys = - get_adt_field_types ctx.type_decls adt_id variant_id adt_generics + get_adt_field_types meta ctx.type_decls adt_id variant_id adt_generics in List.iter (fun ((fid, fe) : _ * texpression) -> let expected_field_ty = FieldId.nth expected_field_tys fid in - assert (expected_field_ty = fe.ty); - check_texpression ctx fe) + cassert (expected_field_ty = fe.ty) meta "TODO: error message"; + check_texpression meta ctx fe) supd.updates | TAssumed TArray -> let expected_field_ty = @@ -219,10 +220,10 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = in List.iter (fun ((_, fe) : _ * texpression) -> - assert (expected_field_ty = fe.ty); - check_texpression ctx fe) + cassert (expected_field_ty = fe.ty) meta "TODO: error message"; + check_texpression meta ctx fe) supd.updates - | _ -> raise (Failure "Unexpected")) + | _ -> craise meta "Unexpected") | Meta (_, e_next) -> - assert (e_next.ty = e.ty); - check_texpression ctx e_next + cassert (e_next.ty = e.ty) meta "TODO: error message"; + check_texpression meta ctx e_next diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 81e3fbe1..05373ce8 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -1,4 +1,5 @@ open Pure +open Errors (** Default logger *) let log = Logging.pure_utils_log @@ -74,10 +75,10 @@ let inputs_info_is_wf (info : inputs_info) : bool = let fun_sig_info_is_wf (info : fun_sig_info) : bool = inputs_info_is_wf info.fwd_info -let dest_arrow_ty (ty : ty) : ty * ty = +let dest_arrow_ty (meta : Meta.meta) (ty : ty) : ty * ty = match ty with | TArrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" let compute_literal_type (cv : literal) : literal_type = match cv with @@ -213,30 +214,30 @@ let fun_sig_substitute (subst : subst) (sg : fun_sig) : inst_fun_sig = Rem.: this function will *fail* if there are {!Pure.Loop} nodes (you should call it on an expression where those nodes have been eliminated). *) -let rec let_group_requires_parentheses (e : texpression) : bool = +let rec let_group_requires_parentheses (meta : Meta.meta) (e : texpression) : bool = match e.e with | Var _ | CVar _ | Const _ | App _ | Qualif _ | StructUpdate _ -> false | Let (monadic, _, _, next_e) -> - if monadic then true else let_group_requires_parentheses next_e + if monadic then true else let_group_requires_parentheses meta next_e | Switch (_, _) -> false - | Meta (_, next_e) -> let_group_requires_parentheses next_e + | Meta (_, next_e) -> let_group_requires_parentheses meta next_e | Lambda (_, _) -> (* Being conservative here *) true | Loop _ -> (* Should have been eliminated *) - raise (Failure "Unreachable") + craise meta "Unreachable" -let texpression_requires_parentheses e = +let texpression_requires_parentheses meta e = match !Config.backend with | FStar | Lean -> false - | Coq | HOL4 -> let_group_requires_parentheses e + | Coq | HOL4 -> let_group_requires_parentheses meta e let is_var (e : texpression) : bool = match e.e with Var _ -> true | _ -> false -let as_var (e : texpression) : VarId.id = - match e.e with Var v -> v | _ -> raise (Failure "Unreachable") +let as_var (meta : Meta.meta) (e : texpression) : VarId.id = + match e.e with Var v -> v | _ -> craise meta "Unreachable" let is_cvar (e : texpression) : bool = match e.e with CVar _ -> true | _ -> false @@ -247,10 +248,10 @@ let is_global (e : texpression) : bool = let is_const (e : texpression) : bool = match e.e with Const _ -> true | _ -> false -let ty_as_adt (ty : ty) : type_id * generic_args = +let ty_as_adt (meta : Meta.meta) (ty : ty) : type_id * generic_args = match ty with | TAdt (id, generics) -> (id, generics) - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" (** Remove the external occurrences of {!Meta} *) let rec unmeta (e : texpression) : texpression = @@ -287,13 +288,13 @@ let rec destruct_lets (e : texpression) : (** Destruct an expression into a list of nested lets, where there is no interleaving between monadic and non-monadic lets. *) -let destruct_lets_no_interleave (e : texpression) : +let destruct_lets_no_interleave (meta : Meta.meta) (e : texpression) : (bool * typed_pattern * texpression) list * texpression = (* Find the "kind" of the first let (monadic or non-monadic) *) let m = match e.e with | Let (monadic, _, _, _) -> monadic - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" in (* Destruct the rest *) let rec destruct_lets (e : texpression) : @@ -320,9 +321,9 @@ let destruct_apps (e : texpression) : texpression * texpression list = aux [] e (** Make an [App (app, arg)] expression *) -let mk_app (app : texpression) (arg : texpression) : texpression = +let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : texpression = let raise_or_return msg = - if !Config.fail_hard then raise (Failure msg) + if !Config.fail_hard then craise meta msg else let e = App (app, arg) in (* Dummy type - TODO: introduce an error type *) @@ -343,8 +344,8 @@ let mk_app (app : texpression) (arg : texpression) : texpression = | _ -> raise_or_return "Expected an arrow type" (** The reverse of {!destruct_apps} *) -let mk_apps (app : texpression) (args : texpression list) : texpression = - List.fold_left (fun app arg -> mk_app app arg) app args +let mk_apps (meta : Meta.meta) (app : texpression) (args : texpression list) : texpression = + List.fold_left (fun app arg -> mk_app meta app arg) app args (** Destruct an expression into a qualif identifier and a list of arguments, * if possible *) @@ -367,28 +368,28 @@ let opt_destruct_function_call (e : texpression) : | FunOrOp fun_id -> Some (fun_id, qualif.generics, args) | _ -> None) -let opt_destruct_result (ty : ty) : ty option = +let opt_destruct_result (meta : Meta.meta) (ty : ty) : ty option = match ty with | TAdt (TAssumed TResult, generics) -> - assert (generics.const_generics = []); - assert (generics.trait_refs = []); + cassert (generics.const_generics = []) meta "TODO: Error message"; + cassert (generics.trait_refs = []) meta "TODO: Error message"; Some (Collections.List.to_cons_nil generics.types) | _ -> None -let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) +let destruct_result (meta : Meta.meta) (ty : ty) : ty = Option.get (opt_destruct_result meta ty) -let opt_destruct_tuple (ty : ty) : ty list option = +let opt_destruct_tuple (meta : Meta.meta) (ty : ty) : ty list option = match ty with | TAdt (TTuple, generics) -> - assert (generics.const_generics = []); - assert (generics.trait_refs = []); + cassert (generics.const_generics = []) meta "TODO: Error message"; + cassert (generics.trait_refs = []) meta "TODO: Error message"; Some generics.types | _ -> None -let destruct_arrow (ty : ty) : ty * ty = +let destruct_arrow (meta : Meta.meta) (ty : ty) : ty * ty = match ty with | TArrow (ty0, ty1) -> (ty0, ty1) - | _ -> raise (Failure "Not an arrow type") + | _ -> craise meta "Not an arrow type" let rec destruct_arrows (ty : ty) : ty list * ty = match ty with @@ -422,17 +423,17 @@ let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : f e_else | Match branches -> List.iter (fun (b : match_branch) -> f b.branch) branches -let mk_switch (scrut : texpression) (sb : switch_body) : texpression = +let mk_switch (meta : Meta.meta) (scrut : texpression) (sb : switch_body) : texpression = (* Sanity check: the scrutinee has the proper type *) (match sb with - | If (_, _) -> assert (scrut.ty = TLiteral TBool) + | If (_, _) -> cassert (scrut.ty = TLiteral TBool) meta "The scrutinee does not have the proper type" | Match branches -> List.iter - (fun (b : match_branch) -> assert (b.pat.ty = scrut.ty)) + (fun (b : match_branch) -> cassert (b.pat.ty = scrut.ty) meta "The scrutinee does not have the proper type") branches); (* Sanity check: all the branches have the same type *) let ty = get_switch_body_ty sb in - iter_switch_body_branches (fun e -> assert (e.ty = ty)) sb; + iter_switch_body_branches (fun e -> cassert (e.ty = ty) meta "All branches should have the same type") sb; (* Put together *) let e = Switch (scrut, sb) in { e; ty } @@ -497,7 +498,7 @@ let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = { value; ty } (** Similar to {!mk_simpl_tuple_pattern} *) -let mk_simpl_tuple_texpression (vl : texpression list) : texpression = +let mk_simpl_tuple_texpression (meta : Meta.meta) (vl : texpression list) : texpression = match vl with | [ v ] -> v | _ -> @@ -510,20 +511,20 @@ let mk_simpl_tuple_texpression (vl : texpression list) : texpression = let qualif = { id; generics = mk_generic_args_from_types tys } in (* Put everything together *) let cons = { e = Qualif qualif; ty } in - mk_apps cons vl + mk_apps meta cons vl let mk_adt_pattern (adt_ty : ty) (variant_id : VariantId.id option) (vl : typed_pattern list) : typed_pattern = let value = PatAdt { variant_id; field_values = vl } in { value; ty = adt_ty } -let ty_as_integer (t : ty) : T.integer_type = +let ty_as_integer (meta : Meta.meta) (t : ty) : T.integer_type = match t with | TLiteral (TInteger int_ty) -> int_ty - | _ -> raise (Failure "Unreachable") + | _ -> craise meta "Unreachable" -let ty_as_literal (t : ty) : T.literal_type = - match t with TLiteral ty -> ty | _ -> raise (Failure "Unreachable") +let ty_as_literal (meta : Meta.meta) (t : ty) : T.literal_type = + match t with TLiteral ty -> ty | _ -> craise meta "Unreachable" let mk_state_ty : ty = TAdt (TAssumed TState, empty_generic_args) @@ -540,15 +541,15 @@ let mk_error (error : VariantId.id) : texpression = let e = Qualif qualif in { e; ty } -let unwrap_result_ty (ty : ty) : ty = +let unwrap_result_ty (meta : Meta.meta) (ty : ty) : ty = match ty with | TAdt ( TAssumed TResult, { types = [ ty ]; const_generics = []; trait_refs = [] } ) -> ty - | _ -> raise (Failure "not a result type") + | _ -> craise meta "not a result type" -let mk_result_fail_texpression (error : texpression) (ty : ty) : texpression = +let mk_result_fail_texpression (meta : Meta.meta) (error : texpression) (ty : ty) : texpression = let type_args = [ ty ] in let ty = TAdt (TAssumed TResult, mk_generic_args_from_types type_args) in let id = @@ -558,14 +559,14 @@ let mk_result_fail_texpression (error : texpression) (ty : ty) : texpression = let cons_e = Qualif qualif in let cons_ty = mk_arrow error.ty ty in let cons = { e = cons_e; ty = cons_ty } in - mk_app cons error + mk_app meta cons error -let mk_result_fail_texpression_with_error_id (error : VariantId.id) (ty : ty) : +let mk_result_fail_texpression_with_error_id (meta : Meta.meta) (error : VariantId.id) (ty : ty) : texpression = let error = mk_error error in - mk_result_fail_texpression error ty + mk_result_fail_texpression meta error ty -let mk_result_return_texpression (v : texpression) : texpression = +let mk_result_return_texpression (meta : Meta.meta) (v : texpression) : texpression = let type_args = [ v.ty ] in let ty = TAdt (TAssumed TResult, mk_generic_args_from_types type_args) in let id = @@ -575,7 +576,7 @@ let mk_result_return_texpression (v : texpression) : texpression = let cons_e = Qualif qualif in let cons_ty = mk_arrow v.ty ty in let cons = { e = cons_e; ty = cons_ty } in - mk_app cons v + mk_app meta cons v (** Create a [Fail err] pattern which captures the error *) let mk_result_fail_pattern (error_pat : pattern) (ty : ty) : typed_pattern = @@ -613,7 +614,7 @@ let mk_fuel_var (id : VarId.id) : var = let mk_fuel_texpression (id : VarId.id) : texpression = { e = Var id; ty = mk_fuel_ty } -let rec typed_pattern_to_texpression (pat : typed_pattern) : texpression option +let rec typed_pattern_to_texpression (meta : Meta.meta) (pat : typed_pattern) : texpression option = let e_opt = match pat.value with @@ -621,13 +622,13 @@ let rec typed_pattern_to_texpression (pat : typed_pattern) : texpression option | PatVar (v, _) -> Some (Var v.id) | PatDummy -> None | PatAdt av -> - let fields = List.map typed_pattern_to_texpression av.field_values in + let fields = List.map (typed_pattern_to_texpression meta) av.field_values in if List.mem None fields then None else let fields_values = List.map (fun e -> Option.get e) fields in (* Retrieve the type id and the type args from the pat type (simpler this way *) - let adt_id, generics = ty_as_adt pat.ty in + let adt_id, generics = ty_as_adt meta pat.ty in (* Create the constructor *) let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in @@ -640,7 +641,7 @@ let rec typed_pattern_to_texpression (pat : typed_pattern) : texpression option let cons = { e = cons_e; ty = cons_ty } in (* Apply the constructor *) - Some (mk_apps cons fields_values).e + Some (mk_apps meta cons fields_values).e in match e_opt with None -> None | Some e -> Some { e; ty = pat.ty } diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index 0b589453..4ebdd01a 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -34,23 +34,24 @@ open LlbcAst open LlbcAstUtils open Assumed open SCC +open Errors module Subst = Substitute (** The local logger *) let log = Logging.regions_hierarchy_log -let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) +let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : type_decl TypeDeclId.Map.t) (fun_decls : fun_decl FunDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) - (trait_impls : trait_impl TraitImplId.Map.t) (fun_name : string) + (trait_impls : trait_impl TraitImplId.Map.t) (* ?meta *) (fun_name : string) (sg : fun_sig) : region_var_groups = log#ldebug (lazy (__FUNCTION__ ^ ": " ^ fun_name)); (* Initialize a normalization context (we may need to normalize some associated types) *) let norm_ctx : AssociatedTypes.norm_ctx = let norm_trait_types = - AssociatedTypes.compute_norm_trait_types_from_preds + AssociatedTypes.compute_norm_trait_types_from_preds meta sg.preds.trait_type_constraints in { @@ -105,8 +106,8 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) let add_edge ~(short : region) ~(long : region) = (* Sanity checks *) - assert (short <> RErased); - assert (long <> RErased); + cassert_opt_meta (short <> RErased) meta "TODO: Error message"; + cassert_opt_meta (long <> RErased) meta "TODO: Error message"; (* Ignore the locally bound regions (at the level of arrow types for instance *) match (short, long) with | RBVar _, _ | _, RBVar _ -> () @@ -172,13 +173,13 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) | TTraitType (trait_ref, _) -> (* The trait should reference a clause, and not an implementation (otherwise it should have been normalized) *) - assert ( - AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id); + cassert_opt_meta ( + AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id) meta "The trait should reference a clause, and not an implementation (otherwise it should have been normalized)"; (* We have nothing to do *) () | TArrow (regions, inputs, output) -> (* TODO: *) - assert (regions = []); + cassert_opt_meta (regions = []) meta "Regions should be empty"; (* We can ignore the outer regions *) List.iter (explore_ty []) (output :: inputs) and explore_generics (outer : region list) (generics : generic_args) = @@ -221,7 +222,7 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) (SccId.Map.bindings sccs.sccs) in (* The SCC should only contain the 'static *) - assert (static_scc = [ RStatic ]); + cassert_opt_meta (static_scc = [ RStatic ]) meta "The SCC should only contain the 'static"; (* Remove the group as well as references to this group from the other SCCs *) let { sccs; scc_deps } = sccs in @@ -277,7 +278,7 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) (fun r -> match r with | RFVar rid -> RegionId.Map.find rid region_id_to_var_map - | _ -> raise (Failure "Unreachable")) + | _ -> craise (Option.get meta) "Unreachable") scc in @@ -317,19 +318,19 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) let regular = List.map (fun ((fid, d) : FunDeclId.id * fun_decl) -> - (FRegular fid, (Types.name_to_string env d.name, d.signature))) + (FRegular fid, (Types.name_to_string env d.name, d.signature, Some d.meta))) (FunDeclId.Map.bindings fun_decls) in let assumed = List.map (fun (info : assumed_fun_info) -> - (FAssumed info.fun_id, (info.name, info.fun_sig))) + (FAssumed info.fun_id, (info.name, info.fun_sig, None))) assumed_fun_infos in FunIdMap.of_list (List.map - (fun (fid, (name, sg)) -> + (fun (fid, (name, sg, meta)) -> ( fid, - compute_regions_hierarchy_for_sig type_decls fun_decls global_decls - trait_decls trait_impls name sg )) + compute_regions_hierarchy_for_sig meta type_decls fun_decls global_decls + trait_decls trait_impls name sg)) (regular @ assumed)) diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index dbd310b7..a35fdbf3 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -7,6 +7,7 @@ open Types open Values open LlbcAst open Contexts +open Errors (** Generate fresh regions for region variables. @@ -67,25 +68,25 @@ let ctx_adt_get_instantiated_field_types (ctx : eval_ctx) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_value_get_instantiated_field_types (ctx : eval_ctx) +let ctx_adt_value_get_instantiated_field_types (meta : Meta.meta) (ctx : eval_ctx) (adt : adt_value) (id : type_id) (generics : generic_args) : ty list = match id with | TAdtId id -> (* Retrieve the types of the fields *) ctx_adt_get_instantiated_field_types ctx id adt.variant_id generics | TTuple -> - assert (generics.regions = []); + cassert (generics.regions = []) meta "Regions should be empty TODO: error message"; generics.types | TAssumed aty -> ( match aty with | TBox -> - assert (generics.regions = []); - assert (List.length generics.types = 1); - assert (generics.const_generics = []); + cassert (generics.regions = []) meta "Regions should be empty TODO: error message"; + cassert (List.length generics.types = 1) meta "Too many types TODO: error message"; + cassert (generics.const_generics = []) meta "const_generics should be empty TODO: error message"; generics.types | TArray | TSlice | TStr -> (* Those types don't have fields *) - raise (Failure "Unreachable")) + craise meta "Unreachable") (** Substitute a function signature, together with the regions hierarchy associated to that signature. @@ -144,30 +145,30 @@ let subst_ids_visitor (r_subst : RegionId.id -> RegionId.id) method! visit_abstraction_id _ id = asubst id end -let typed_value_subst_ids (r_subst : RegionId.id -> RegionId.id) +let typed_value_subst_ids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> TypeVarId.id) (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ssubst : SymbolicValueId.id -> SymbolicValueId.id) (bsubst : BorrowId.id -> BorrowId.id) (v : typed_value) : typed_value = - let asubst _ = raise (Failure "Unreachable") in + let asubst _ = craise meta "Unreachable" in let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_value () v -let typed_value_subst_rids (r_subst : RegionId.id -> RegionId.id) +let typed_value_subst_rids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) (v : typed_value) : typed_value = - typed_value_subst_ids r_subst + typed_value_subst_ids meta r_subst (fun x -> x) (fun x -> x) (fun x -> x) (fun x -> x) v -let typed_avalue_subst_ids (r_subst : RegionId.id -> RegionId.id) +let typed_avalue_subst_ids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> TypeVarId.id) (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ssubst : SymbolicValueId.id -> SymbolicValueId.id) (bsubst : BorrowId.id -> BorrowId.id) (v : typed_avalue) : typed_avalue = - let asubst _ = raise (Failure "Unreachable") in + let asubst _ = craise meta "Unreachable" in let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_avalue () v @@ -189,9 +190,9 @@ let env_subst_ids (r_subst : RegionId.id -> RegionId.id) let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_env () x -let typed_avalue_subst_rids (r_subst : RegionId.id -> RegionId.id) +let typed_avalue_subst_rids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) (x : typed_avalue) : typed_avalue = - let asubst _ = raise (Failure "Unreachable") in + let asubst _ = craise meta "Unreachable" in let vis = subst_ids_visitor r_subst (fun x -> x) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index b612ab70..6e3a537e 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -325,7 +325,7 @@ let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = let typed_value_to_string (ctx : bs_ctx) (v : V.typed_value) : string = let env = bs_ctx_to_fmt_env ctx in - Print.Values.typed_value_to_string env v + Print.Values.typed_value_to_string ctx.fun_decl.meta env v let pure_ty_to_string (ctx : bs_ctx) (ty : ty) : string = let env = bs_ctx_to_pure_fmt_env ctx in @@ -349,7 +349,7 @@ let pure_type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.texpression_to_string env false "" " " e + PrintPure.texpression_to_string ctx.fun_decl.meta env false "" " " e let fun_id_to_string (ctx : bs_ctx) (id : A.fun_id) : string = let env = bs_ctx_to_fmt_env ctx in @@ -363,9 +363,9 @@ let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = let env = bs_ctx_to_pure_fmt_env ctx in PrintPure.fun_decl_to_string env def -let typed_pattern_to_string (ctx : bs_ctx) (p : Pure.typed_pattern) : string = +let typed_pattern_to_string (meta : Meta.meta) (ctx : bs_ctx) (p : Pure.typed_pattern) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.typed_pattern_to_string env p + PrintPure.typed_pattern_to_string meta env p let ctx_get_effect_info_for_bid (ctx : bs_ctx) (bid : RegionGroupId.id option) : fun_effect_info = @@ -384,7 +384,7 @@ let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = let verbose = false in let indent = "" in let indent_incr = " " in - Print.Values.abs_to_string env verbose indent indent_incr abs + Print.Values.abs_to_string ctx.fun_decl.meta env verbose indent indent_incr abs let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : T.type_decl = @@ -450,7 +450,7 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = match type_id with | T.TAdtId adt_id -> TAdt (TAdtId adt_id, generics) | T.TTuple -> - assert (generics.const_generics = []); + cassert (generics.const_generics = []) meta "TODO: error message"; mk_simpl_tuple_ty generics.types | T.TAssumed aty -> ( match aty with @@ -541,7 +541,7 @@ let translate_type_decl_kind (meta : Meta.meta) (kind : T.type_decl_kind) : type Remark: this is not symbolic to pure but LLBC to pure. Still, I don't see the point of moving this definition for now. *) -let translate_type_decl (meta : Meta.meta) (ctx : Contexts.decls_ctx) (def : T.type_decl) : +let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : type_decl = log#ldebug (lazy @@ -555,11 +555,11 @@ let translate_type_decl (meta : Meta.meta) (ctx : Contexts.decls_ctx) (def : T.t let name = Print.Types.name_to_string env def.name in let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) - assert (regions = []); - let trait_clauses = List.map (translate_trait_clause meta) trait_clauses in + cassert (regions = []) def.meta "Translating types with regions is not supported yet"; + let trait_clauses = List.map (translate_trait_clause def.meta) trait_clauses in let generics = { types; const_generics; trait_clauses } in - let kind = translate_type_decl_kind meta def.T.kind in - let preds = translate_predicates meta def.preds in + let kind = translate_type_decl_kind def.meta def.T.kind in + let preds = translate_predicates def.meta def.preds in let is_local = def.is_local in let meta = def.meta in { @@ -616,11 +616,11 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) (ty : T.ty | TAssumed TBox -> ( (* We eliminate boxes *) (* No general parametricity for now *) - assert ( + cassert ( not (List.exists (TypesUtils.ty_has_borrows type_infos) - generics.types)); + generics.types)) meta "General parametricity is not supported yet"; match t_generics.types with | [ bty ] -> bty | _ -> @@ -655,15 +655,15 @@ and translate_fwd_trait_instance_id (meta : Meta.meta) (type_infos : type_infos) translate_trait_instance_id meta (translate_fwd_ty meta type_infos) id (** Simply calls [translate_fwd_ty] *) -let ctx_translate_fwd_ty (meta : Meta.meta) (ctx : bs_ctx) (ty : T.ty) : ty = +let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : T.ty) : ty = let type_infos = ctx.type_ctx.type_infos in - translate_fwd_ty meta type_infos ty + translate_fwd_ty ctx.fun_decl.meta type_infos ty (** Simply calls [translate_fwd_generic_args] *) -let ctx_translate_fwd_generic_args (meta : Meta.meta) (ctx : bs_ctx) (generics : T.generic_args) : +let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : T.generic_args) : generic_args = let type_infos = ctx.type_ctx.type_infos in - translate_fwd_generic_args meta type_infos generics + translate_fwd_generic_args ctx.fun_decl.meta type_infos generics (** Translate a type, when some regions may have ended. @@ -701,7 +701,7 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) else None | TAssumed TBox -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) - assert (not (TypesUtils.ty_has_borrows type_infos ty)); + cassert (not (TypesUtils.ty_has_borrows type_infos ty)) meta "ADTs with borrows are not supported yet"; (* Eliminate the box *) match generics.types with | [ bty ] -> translate bty @@ -747,17 +747,17 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) | TArrow _ -> craise meta "TODO" (** Simply calls [translate_back_ty] *) -let ctx_translate_back_ty (meta : Meta.meta) (ctx : bs_ctx) (keep_region : 'r -> bool) +let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) (inside_mut : bool) (ty : T.ty) : ty option = let type_infos = ctx.type_ctx.type_infos in - translate_back_ty meta type_infos keep_region inside_mut ty + translate_back_ty ctx.fun_decl.meta type_infos keep_region inside_mut ty -let mk_type_check_ctx (meta : Meta.meta) (ctx : bs_ctx) : PureTypeCheck.tc_ctx = +let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = let const_generics = T.ConstGenericVarId.Map.of_list (List.map (fun (cg : T.const_generic_var) -> - (cg.index, ctx_translate_fwd_ty meta ctx (T.TLiteral cg.ty))) + (cg.index, ctx_translate_fwd_ty ctx (T.TLiteral cg.ty))) ctx.sg.generics.const_generics) in let env = VarId.Map.empty in @@ -768,23 +768,25 @@ let mk_type_check_ctx (meta : Meta.meta) (ctx : bs_ctx) : PureTypeCheck.tc_ctx = const_generics; } -let type_check_pattern (meta : Meta.meta) (ctx : bs_ctx) (v : typed_pattern) : unit = - let ctx = mk_type_check_ctx meta ctx in - let _ = PureTypeCheck.check_typed_pattern ctx v in +let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = + let meta = ctx.fun_decl.meta in + let ctx = mk_type_check_ctx ctx in + let _ = PureTypeCheck.check_typed_pattern meta ctx v in () -let type_check_texpression (meta : Meta.meta) (ctx : bs_ctx) (e : texpression) : unit = +let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = if !Config.type_check_pure_code then - let ctx = mk_type_check_ctx meta ctx in - PureTypeCheck.check_texpression ctx e + let meta = ctx.fun_decl.meta in + let ctx = mk_type_check_ctx ctx in + PureTypeCheck.check_texpression meta ctx e -let translate_fun_id_or_trait_method_ref (meta : Meta.meta) (ctx : bs_ctx) +let translate_fun_id_or_trait_method_ref (ctx : bs_ctx) (id : A.fun_id_or_trait_method_ref) : fun_id_or_trait_method_ref = match id with | FunId fun_id -> FunId fun_id | TraitMethod (trait_ref, method_name, fun_decl_id) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in + let trait_ref = translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref in TraitMethod (trait_ref, method_name, fun_decl_id) let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) @@ -792,7 +794,7 @@ let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) (back_funs : texpression option RegionGroupId.Map.t option) (ctx : bs_ctx) : bs_ctx = let calls = ctx.calls in - assert (not (V.FunCallId.Map.mem call_id calls)); + cassert (not (V.FunCallId.Map.mem call_id calls)) ctx.fun_decl.meta "TODO: error message"; let info = { forward; forward_inputs = args; back_funs } in let calls = V.FunCallId.Map.add call_id info calls in { ctx with calls } @@ -806,7 +808,7 @@ let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) that we need to call. This function may be [None] if it has to be ignored (because it does nothing). *) -let bs_ctx_register_backward_call (meta : Meta.meta) (abs : V.abs) (call_id : V.FunCallId.id) +let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) (back_id : T.RegionGroupId.id) (back_args : texpression list) (ctx : bs_ctx) : bs_ctx * texpression option = (* Insert the abstraction in the call informations *) @@ -814,7 +816,7 @@ let bs_ctx_register_backward_call (meta : Meta.meta) (abs : V.abs) (call_id : V. let calls = V.FunCallId.Map.add call_id info ctx.calls in (* Insert the abstraction in the abstractions map *) let abstractions = ctx.abstractions in - assert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)); + cassert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) ctx.fun_decl.meta "This abstraction should not be in the abstractions map"; let abstractions = V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions in @@ -876,7 +878,7 @@ let mk_fuel_input_as_list (ctx : bs_ctx) (info : fun_effect_info) : if function_uses_fuel info then [ mk_fuel_texpression ctx.fuel ] else [] (** Small utility. *) -let compute_raw_fun_effect_info (fun_infos : fun_info A.FunDeclId.Map.t) +let compute_raw_fun_effect_info (* (meta : Meta.meta) *) (fun_infos : fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with @@ -894,7 +896,7 @@ let compute_raw_fun_effect_info (fun_infos : fun_info A.FunDeclId.Map.t) is_rec = info.is_rec || Option.is_some lid; } | FunId (FAssumed aid) -> - assert (lid = None); + assert (lid = None) (* meta "TODO: error message" *); { can_fail = Assumed.assumed_fun_can_fail aid; stateful_group = false; @@ -904,7 +906,7 @@ let compute_raw_fun_effect_info (fun_infos : fun_info A.FunDeclId.Map.t) } (** TODO: not very clean. *) -let get_fun_effect_info (meta : Meta.meta) (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) +let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match lid with @@ -919,19 +921,19 @@ let get_fun_effect_info (meta : Meta.meta) (ctx : bs_ctx) (fun_id : A.fun_id_or_ in { info with is_rec = info.is_rec || Option.is_some lid } | FunId (FAssumed _) -> - compute_raw_fun_effect_info ctx.fun_ctx.fun_infos fun_id lid gid) + compute_raw_fun_effect_info (* ctx.fun_decl.meta *) ctx.fun_ctx.fun_infos fun_id lid gid) | Some lid -> ( (* This is necessarily for the current function *) match fun_id with | FunId (FRegular fid) -> ( - assert (fid = ctx.fun_decl.def_id); + cassert (fid = ctx.fun_decl.def_id) ctx.fun_decl.meta "TODO: error message"; (* Lookup the loop *) let lid = V.LoopId.Map.find lid ctx.loop_ids_map in let loop_info = LoopId.Map.find lid ctx.loops in match gid with | None -> loop_info.fwd_effect_info | Some gid -> RegionGroupId.Map.find gid loop_info.back_effect_infos) - | _ -> craise meta "Unreachable") + | _ -> craise ctx.fun_decl.meta "Unreachable") (** Translate a function signature to a decomposed function signature. @@ -960,11 +962,11 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) List.map (fun (g : T.region_var_group) -> g.id) regions_hierarchy in let ctx = - InterpreterUtils.initialize_eval_ctx decls_ctx region_groups + InterpreterUtils.initialize_eval_ctx meta decls_ctx region_groups sg.generics.types sg.generics.const_generics in (* Compute the normalization map for the *sty* types and add it to the context *) - AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx + AssociatedTypes.ctx_add_norm_trait_types_from_preds meta ctx sg.preds.trait_type_constraints in @@ -1029,7 +1031,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) (* For now we don't supported nested borrows, so we check that there aren't parent regions *) let parents = list_ancestor_region_groups regions_hierarchy gid in - assert (T.RegionGroupId.Set.is_empty parents); + cassert (T.RegionGroupId.Set.is_empty parents) meta "Nested borrows are not supported yet"; (* For now, we don't allow nested borrows, so the additional inputs to the backward function can only come from borrows that were returned like in (for the backward function we introduce for 'a): @@ -1186,7 +1188,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) else false in let info = { fwd_info; effect_info = fwd_effect_info; ignore_output } in - assert (fun_sig_info_is_wf info); + cassert (fun_sig_info_is_wf info) meta "TODO: error message"; info in @@ -1205,17 +1207,18 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) fwd_info; } -let translate_fun_sig_to_decomposed (meta : Meta.meta) (decls_ctx : C.decls_ctx) +let translate_fun_sig_to_decomposed (decls_ctx : C.decls_ctx) (fun_id : FunDeclId.id) (sg : A.fun_sig) (input_names : string option list) : decomposed_fun_sig = (* Retrieve the list of parent backward functions *) let regions_hierarchy = FunIdMap.find (FRegular fun_id) decls_ctx.fun_ctx.regions_hierarchies in + let meta = (FunDeclId.Map.find fun_id decls_ctx.fun_ctx.fun_decls).meta in translate_fun_sig_with_regions_hierarchy_to_decomposed meta decls_ctx (FunId (FRegular fun_id)) regions_hierarchy sg input_names -let translate_fun_sig_from_decl_to_decomposed (meta : Meta.meta) (decls_ctx : C.decls_ctx) +let translate_fun_sig_from_decl_to_decomposed (decls_ctx : C.decls_ctx) (fdef : LlbcAst.fun_decl) : decomposed_fun_sig = let input_names = match fdef.body with @@ -1226,7 +1229,7 @@ let translate_fun_sig_from_decl_to_decomposed (meta : Meta.meta) (decls_ctx : C. (LlbcAstUtils.fun_body_get_input_vars body) in let sg = - translate_fun_sig_to_decomposed meta decls_ctx fdef.def_id fdef.signature + translate_fun_sig_to_decomposed decls_ctx fdef.def_id fdef.signature input_names in log#ldebug @@ -1322,7 +1325,7 @@ let compute_output_ty_from_decomposed (dsg : Pure.decomposed_fun_sig) : ty = in mk_output_ty_from_effect_info effect_info output -let translate_fun_sig_from_decomposed (dsg : Pure.decomposed_fun_sig) : fun_sig +let translate_fun_sig_from_decomposed (meta : Meta.meta) (dsg : Pure.decomposed_fun_sig) : fun_sig = let generics = dsg.generics in let llbc_generics = dsg.llbc_generics in @@ -1358,21 +1361,21 @@ let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * var * typed_pattern = (** WARNING: do not call this function directly. Call [fresh_named_var_for_symbolic_value] instead. *) -let fresh_var_llbc_ty (meta : Meta.meta) (basename : string option) (ty : T.ty) (ctx : bs_ctx) : +let fresh_var_llbc_ty (basename : string option) (ty : T.ty) (ctx : bs_ctx) : bs_ctx * var = (* Generate the fresh variable *) let id, var_counter = VarId.fresh !(ctx.var_counter) in - let ty = ctx_translate_fwd_ty meta ctx ty in + let ty = ctx_translate_fwd_ty ctx ty in let var = { id; basename; ty } in (* Update the context *) ctx.var_counter := var_counter; (* Return *) (ctx, var) -let fresh_named_var_for_symbolic_value (meta : Meta.meta) (basename : string option) +let fresh_named_var_for_symbolic_value (basename : string option) (sv : V.symbolic_value) (ctx : bs_ctx) : bs_ctx * var = (* Generate the fresh variable *) - let ctx, var = fresh_var_llbc_ty meta basename sv.sv_ty ctx in + let ctx, var = fresh_var_llbc_ty basename sv.sv_ty ctx in (* Insert in the map *) let sv_to_var = V.SymbolicValueId.Map.add_strict sv.sv_id var ctx.sv_to_var in (* Update the context *) @@ -1380,19 +1383,19 @@ let fresh_named_var_for_symbolic_value (meta : Meta.meta) (basename : string opt (* Return *) (ctx, var) -let fresh_var_for_symbolic_value (meta : Meta.meta) (sv : V.symbolic_value) (ctx : bs_ctx) : +let fresh_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : bs_ctx * var = - fresh_named_var_for_symbolic_value meta None sv ctx + fresh_named_var_for_symbolic_value None sv ctx -let fresh_vars_for_symbolic_values (meta : Meta.meta) (svl : V.symbolic_value list) (ctx : bs_ctx) +let fresh_vars_for_symbolic_values (svl : V.symbolic_value list) (ctx : bs_ctx) : bs_ctx * var list = - List.fold_left_map (fun ctx sv -> fresh_var_for_symbolic_value meta sv ctx) ctx svl + List.fold_left_map (fun ctx sv -> fresh_var_for_symbolic_value sv ctx) ctx svl -let fresh_named_vars_for_symbolic_values (meta : Meta.meta) +let fresh_named_vars_for_symbolic_values (svl : (string option * V.symbolic_value) list) (ctx : bs_ctx) : bs_ctx * var list = List.fold_left_map - (fun ctx (name, sv) -> fresh_named_var_for_symbolic_value meta name sv ctx) + (fun ctx (name, sv) -> fresh_named_var_for_symbolic_value name sv ctx) ctx svl (** This generates a fresh variable **which is not to be linked to any symbolic value** *) @@ -1470,12 +1473,12 @@ let fresh_back_vars_for_current_fun (ctx : bs_ctx) fresh_opt_vars back_vars ctx (** IMPORTANT: do not use this one directly, but rather {!symbolic_value_to_texpression} *) -let lookup_var_for_symbolic_value (meta : Meta.meta) (sv : V.symbolic_value) (ctx : bs_ctx) : var = +let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = match V.SymbolicValueId.Map.find_opt sv.sv_id ctx.sv_to_var with | Some v -> v | None -> craise - meta + ctx.fun_decl.meta ("Could not find var for symbolic value: " ^ V.SymbolicValueId.to_string sv.sv_id) @@ -1494,15 +1497,15 @@ let rec unbox_typed_value (meta : Meta.meta) (v : V.typed_value) : V.typed_value of (translated) type unit, it is important that we do not lookup variables in case the symbolic value has type unit. *) -let symbolic_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (sv : V.symbolic_value) : +let symbolic_value_to_texpression (ctx : bs_ctx) (sv : V.symbolic_value) : texpression = (* Translate the type *) - let ty = ctx_translate_fwd_ty meta ctx sv.sv_ty in + let ty = ctx_translate_fwd_ty ctx sv.sv_ty in (* If the type is unit, directly return unit *) if ty_is_unit ty then mk_unit_rvalue else (* Otherwise lookup the variable *) - let var = lookup_var_for_symbolic_value meta sv ctx in + let var = lookup_var_for_symbolic_value sv ctx in mk_texpression_from_var var (** Translate a typed value. @@ -1521,13 +1524,13 @@ let symbolic_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (sv : V.symb - end abstraction - return *) -let rec typed_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_ctx) +let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) (v : V.typed_value) : texpression = (* We need to ignore boxes *) - let v = unbox_typed_value meta v in - let translate = typed_value_to_texpression meta ctx ectx in + let v = unbox_typed_value ctx.fun_decl.meta v in + let translate = typed_value_to_texpression ctx ectx in (* Translate the type *) - let ty = ctx_translate_fwd_ty meta ctx v.ty in + let ty = ctx_translate_fwd_ty ctx v.ty in (* Translate the value *) let value = match v.value with @@ -1538,12 +1541,12 @@ let rec typed_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.e (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) match v.ty with | TAdt (TTuple, _) -> - assert (variant_id = None); - mk_simpl_tuple_texpression field_values + cassert (variant_id = None) ctx.fun_decl.meta "TODO: error message"; + mk_simpl_tuple_texpression ctx.fun_decl.meta field_values | _ -> (* Retrieve the type and the translated generics from the translated type (simpler this way) *) - let adt_id, generics = ty_as_adt ty in + let adt_id, generics = ty_as_adt ctx.fun_decl.meta ty in (* Create the constructor *) let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in let qualif = { id = qualif_id; generics } in @@ -1554,28 +1557,28 @@ let rec typed_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.e let cons_ty = mk_arrows field_tys ty in let cons = { e = cons_e; ty = cons_ty } in (* Apply the constructor *) - mk_apps cons field_values) - | VBottom -> craise meta "Unreachable" + mk_apps ctx.fun_decl.meta cons field_values) + | VBottom -> craise ctx.fun_decl.meta "Unreachable" | VLoan lc -> ( match lc with | VSharedLoan (_, v) -> translate v - | VMutLoan _ -> craise meta "Unreachable") + | VMutLoan _ -> craise ctx.fun_decl.meta "Unreachable") | VBorrow bc -> ( match bc with | VSharedBorrow bid -> (* Lookup the shared value in the context, and continue *) - let sv = InterpreterBorrowsCore.lookup_shared_value meta ectx bid in + let sv = InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx bid in translate sv | VReservedMutBorrow bid -> (* Same as for shared borrows. However, note that we use reserved borrows * only in *meta-data*: a value *actually used* in the translation can't come * from an unpromoted reserved borrow *) - let sv = InterpreterBorrowsCore.lookup_shared_value meta ectx bid in + let sv = InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx bid in translate sv | VMutBorrow (_, v) -> (* Borrows are the identity in the extraction *) translate v) - | VSymbolic sv -> symbolic_value_to_texpression meta ctx sv + | VSymbolic sv -> symbolic_value_to_texpression ctx sv in (* Debugging *) log#ldebug @@ -1585,7 +1588,7 @@ let rec typed_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.e ^ "\n- translated expression:\n" ^ texpression_to_string ctx value)); (* Sanity check *) - type_check_texpression meta ctx value; + type_check_texpression ctx value; (* Return *) value @@ -1604,9 +1607,9 @@ let rec typed_value_to_texpression (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.e ^^ ]} *) -let rec typed_avalue_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_ctx) +let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (av : V.typed_avalue) : texpression option = - let translate = typed_avalue_to_consumed meta ctx ectx in + let translate = typed_avalue_to_consumed ctx ectx in let value = match av.value with | AAdt adt_v -> ( @@ -1616,7 +1619,7 @@ let rec typed_avalue_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eva let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - assert (field_values = []); + cassert (field_values = []) ctx.fun_decl.meta "Only tuples can currently contain borrows"; None | TTuple -> (* Return *) @@ -1624,29 +1627,29 @@ let rec typed_avalue_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eva else (* Note that if there is exactly one field value, * [mk_simpl_tuple_rvalue] is the identity *) - let rv = mk_simpl_tuple_texpression field_values in + let rv = mk_simpl_tuple_texpression ctx.fun_decl.meta field_values in Some rv) - | ABottom -> craise meta "Unreachable" - | ALoan lc -> aloan_content_to_consumed meta ctx ectx lc - | ABorrow bc -> aborrow_content_to_consumed meta ctx bc - | ASymbolic aproj -> aproj_to_consumed meta ctx aproj + | ABottom -> craise ctx.fun_decl.meta "Unreachable" + | ALoan lc -> aloan_content_to_consumed ctx ectx lc + | ABorrow bc -> aborrow_content_to_consumed ctx bc + | ASymbolic aproj -> aproj_to_consumed ctx aproj | AIgnored -> None in (* Sanity check - Rk.: we do this at every recursive call, which is a bit * expansive... *) (match value with | None -> () - | Some value -> type_check_texpression meta ctx value); + | Some value -> type_check_texpression ctx value); (* Return *) value -and aloan_content_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_ctx) +and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (lc : V.aloan_content) : texpression option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise meta "Unreachable" + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise ctx.fun_decl.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> (* Return the meta-value *) - Some (typed_value_to_texpression meta ctx ectx given_back_meta) + Some (typed_value_to_texpression ctx ectx given_back_meta) | AEndedSharedLoan (_, _) -> (* We don't dive into shared loans: there is nothing to give back * inside (note that there could be a mutable borrow in the shared @@ -1655,7 +1658,7 @@ and aloan_content_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_c None | AIgnoredMutLoan (_, _) -> (* There can be *inner* not ended mutable loans, but not outer ones *) - craise meta "Unreachable" + craise ctx.fun_decl.meta "Unreachable" | AEndedIgnoredMutLoan _ -> (* This happens with nested borrows: we need to dive in *) raise Unimplemented @@ -1663,11 +1666,11 @@ and aloan_content_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_c (* Ignore *) None -and aborrow_content_to_consumed (meta : Meta.meta) (_ctx : bs_ctx) (bc : V.aborrow_content) : +and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : texpression option = match bc with | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - craise meta "Unreachable" + craise _ctx.fun_decl.meta "Unreachable" | AEndedMutBorrow (_, _) -> (* We collect consumed values: ignore *) None @@ -1678,31 +1681,31 @@ and aborrow_content_to_consumed (meta : Meta.meta) (_ctx : bs_ctx) (bc : V.aborr (* Ignore *) None -and aproj_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (aproj : V.aproj) : texpression option = +and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = match aproj with | V.AEndedProjLoans (msv, []) -> (* The symbolic value was left unchanged *) - Some (symbolic_value_to_texpression meta ctx msv) + Some (symbolic_value_to_texpression ctx msv) | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> - assert (child_aproj = AIgnoredProjBorrows); + cassert (child_aproj = AIgnoredProjBorrows) ctx.fun_decl.meta "TODO: error message"; (* The symbolic value was updated *) - Some (symbolic_value_to_texpression meta ctx mnv) + Some (symbolic_value_to_texpression ctx mnv) | V.AEndedProjLoans (_, _) -> (* The symbolic value was updated, and the given back values come from sevearl * abstractions *) raise Unimplemented | AEndedProjBorrows _ -> (* We consider consumed values *) None | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - craise meta "Unreachable" + craise ctx.fun_decl.meta "Unreachable" (** Convert the abstraction values in an abstraction to consumed values. See [typed_avalue_to_consumed]. *) -let abs_to_consumed (meta : Meta.meta) (ctx : bs_ctx) (ectx : C.eval_ctx) (abs : V.abs) : +let abs_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (abs : V.abs) : texpression list = log#ldebug (lazy ("abs_to_consumed:\n" ^ abs_to_string ctx abs)); - List.filter_map (typed_avalue_to_consumed meta ctx ectx) abs.avalues + List.filter_map (typed_avalue_to_consumed ctx ectx) abs.avalues let translate_mprojection_elem (pe : E.projection_elem) : mprojection_elem option = @@ -1737,7 +1740,7 @@ let translate_opt_mplace (p : S.mplace option) : mplace option = [mp]: it is possible to provide some meta-place information, to guide the heuristics which later find pretty names for the variables. *) -let rec typed_avalue_to_given_back (meta : Meta.meta) (mp : mplace option) (av : V.typed_avalue) +let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) (ctx : bs_ctx) : bs_ctx * typed_pattern option = let ctx, value = match av.value with @@ -1749,7 +1752,7 @@ let rec typed_avalue_to_given_back (meta : Meta.meta) (mp : mplace option) (av : let mp = None in let ctx, field_values = List.fold_left_map - (fun ctx fv -> typed_avalue_to_given_back meta mp fv ctx) + (fun ctx fv -> typed_avalue_to_given_back mp fv ctx) ctx adt_v.field_values in let field_values = List.filter_map (fun x -> x) field_values in @@ -1759,41 +1762,41 @@ let rec typed_avalue_to_given_back (meta : Meta.meta) (mp : mplace option) (av : let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - assert (field_values = []); + cassert (field_values = []) ctx.fun_decl.meta "Only tuples can currently contain borrows"; (ctx, None) | TTuple -> (* Return *) let variant_id = adt_v.variant_id in - assert (variant_id = None); + cassert (variant_id = None) ctx.fun_decl.meta "TODO: error message"; if field_values = [] then (ctx, None) else (* Note that if there is exactly one field value, [mk_simpl_tuple_pattern] * is the identity *) let lv = mk_simpl_tuple_pattern field_values in (ctx, Some lv)) - | ABottom -> craise meta "Unreachable" - | ALoan lc -> aloan_content_to_given_back meta mp lc ctx - | ABorrow bc -> aborrow_content_to_given_back meta mp bc ctx - | ASymbolic aproj -> aproj_to_given_back meta mp aproj ctx + | ABottom -> craise ctx.fun_decl.meta "Unreachable" + | ALoan lc -> aloan_content_to_given_back mp lc ctx + | ABorrow bc -> aborrow_content_to_given_back mp bc ctx + | ASymbolic aproj -> aproj_to_given_back mp aproj ctx | AIgnored -> (ctx, None) in (* Sanity check - Rk.: we do this at every recursive call, which is a bit * expansive... *) - (match value with None -> () | Some value -> type_check_pattern meta ctx value); + (match value with None -> () | Some value -> type_check_pattern ctx value); (* Return *) (ctx, value) -and aloan_content_to_given_back (meta : Meta.meta) (_mp : mplace option) (lc : V.aloan_content) +and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise meta "Unreachable" + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise ctx.fun_decl.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } | AEndedSharedLoan (_, _) -> (* We consider given back values, and thus ignore those *) (ctx, None) | AIgnoredMutLoan (_, _) -> (* There can be *inner* not ended mutable loans, but not outer ones *) - craise meta "Unreachable" + craise ctx.fun_decl.meta "Unreachable" | AEndedIgnoredMutLoan _ -> (* This happens with nested borrows: we need to dive in *) raise Unimplemented @@ -1801,14 +1804,14 @@ and aloan_content_to_given_back (meta : Meta.meta) (_mp : mplace option) (lc : V (* Ignore *) (ctx, None) -and aborrow_content_to_given_back (meta : Meta.meta) (mp : mplace option) (bc : V.aborrow_content) +and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match bc with | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - craise meta "Unreachable" + craise ctx.fun_decl.meta "Unreachable" | AEndedMutBorrow (msv, _) -> (* Return the meta-symbolic-value *) - let ctx, var = fresh_var_for_symbolic_value meta msv ctx in + let ctx, var = fresh_var_for_symbolic_value msv ctx in (ctx, Some (mk_typed_pattern_from_var var mp)) | AEndedIgnoredMutBorrow _ -> (* This happens with nested borrows: we need to dive in *) @@ -1817,29 +1820,29 @@ and aborrow_content_to_given_back (meta : Meta.meta) (mp : mplace option) (bc : (* Ignore *) (ctx, None) -and aproj_to_given_back (meta : Meta.meta) (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : +and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match aproj with | V.AEndedProjLoans (_, child_projs) -> (* There may be children borrow projections in case of nested borrows, * in which case we need to dive in - we disallow nested borrows for now *) - assert ( + cassert ( List.for_all (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) - child_projs); + child_projs) ctx.fun_decl.meta "Nested borrows are not supported yet"; (ctx, None) | AEndedProjBorrows mv -> (* Return the meta-value *) - let ctx, var = fresh_var_for_symbolic_value meta mv ctx in + let ctx, var = fresh_var_for_symbolic_value mv ctx in (ctx, Some (mk_typed_pattern_from_var var mp)) | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - craise meta "Unreachable" + craise ctx.fun_decl.meta "Unreachable" (** Convert the abstraction values in an abstraction to given back values. See [typed_avalue_to_given_back]. *) -let abs_to_given_back (meta : Meta.meta) (mpl : mplace option list option) (abs : V.abs) +let abs_to_given_back (mpl : mplace option list option) (abs : V.abs) (ctx : bs_ctx) : bs_ctx * typed_pattern list = let avalues = match mpl with @@ -1848,17 +1851,17 @@ let abs_to_given_back (meta : Meta.meta) (mpl : mplace option list option) (abs in let ctx, values = List.fold_left_map - (fun ctx (mp, av) -> typed_avalue_to_given_back meta mp av ctx) + (fun ctx (mp, av) -> typed_avalue_to_given_back mp av ctx) ctx avalues in let values = List.filter_map (fun x -> x) values in (ctx, values) (** Simply calls [abs_to_given_back] *) -let abs_to_given_back_no_mp (meta : Meta.meta) (abs : V.abs) (ctx : bs_ctx) : +let abs_to_given_back_no_mp (abs : V.abs) (ctx : bs_ctx) : bs_ctx * typed_pattern list = let mpl = List.map (fun _ -> None) abs.avalues in - abs_to_given_back meta (Some mpl) abs ctx + abs_to_given_back (Some mpl) abs ctx (** Return the ordered list of the (transitive) parents of a given abstraction. @@ -1917,32 +1920,32 @@ let eval_ctx_to_symbolic_assignments_info (ctx : bs_ctx) (* Return the computed information *) !info -let rec translate_expression (metadata : Meta.meta) (e : S.expression) (ctx : bs_ctx) : texpression = +let rec translate_expression (e : S.expression) (ctx : bs_ctx) : texpression = match e with | S.Return (ectx, opt_v) -> (* We reached a return. Remark: we can't get there if we are inside a loop. *) - translate_return metadata ectx opt_v ctx + translate_return ectx opt_v ctx | ReturnWithLoop (loop_id, is_continue) -> (* We reached a return and are inside a loop. *) translate_return_with_loop loop_id is_continue ctx | Panic -> translate_panic ctx - | FunCall (call, e) -> translate_function_call metadata call e ctx - | EndAbstraction (ectx, abs, e) -> translate_end_abstraction metadata ectx abs e ctx + | FunCall (call, e) -> translate_function_call call e ctx + | EndAbstraction (ectx, abs, e) -> translate_end_abstraction ectx abs e ctx | EvalGlobal (gid, generics, sv, e) -> - translate_global_eval metadata gid generics sv e ctx - | Assertion (ectx, v, e) -> translate_assertion metadata ectx v e ctx - | Expansion (p, sv, exp) -> translate_expansion metadata p sv exp ctx + translate_global_eval gid generics sv e ctx + | Assertion (ectx, v, e) -> translate_assertion ectx v e ctx + | Expansion (p, sv, exp) -> translate_expansion p sv exp ctx | IntroSymbolic (ectx, p, sv, v, e) -> - translate_intro_symbolic metadata ectx p sv v e ctx - | Meta (meta, e) -> translate_emeta metadata meta e ctx + translate_intro_symbolic ectx p sv v e ctx + | Meta (meta, e) -> translate_emeta meta e ctx | ForwardEnd (ectx, loop_input_values, e, back_e) -> (* Translate the end of a function, or the end of a loop. The case where we (re-)enter a loop is handled here. *) - translate_forward_end metadata ectx loop_input_values e back_e ctx - | Loop loop -> translate_loop metadata loop ctx + translate_forward_end ectx loop_input_values e back_e ctx + | Loop loop -> translate_loop loop ctx and translate_panic (ctx : bs_ctx) : texpression = (* Here we use the function return type - note that it is ok because @@ -1957,10 +1960,10 @@ and translate_panic (ctx : bs_ctx) : texpression = (* Create the [Fail] value *) let ret_ty = mk_simpl_tuple_ty [ mk_state_ty; output_ty ] in let ret_v = - mk_result_fail_texpression_with_error_id error_failure_id ret_ty + mk_result_fail_texpression_with_error_id ctx.fun_decl.meta error_failure_id ret_ty in ret_v - else mk_result_fail_texpression_with_error_id error_failure_id output_ty + else mk_result_fail_texpression_with_error_id ctx.fun_decl.meta error_failure_id output_ty in if ctx.inside_loop && Option.is_some ctx.bid then (* We are synthesizing the backward function of a loop body *) @@ -1998,7 +2001,7 @@ and translate_panic (ctx : bs_ctx) : texpression = Remark: in case we merge the forward/backward functions, we introduce those in [translate_forward_end]. *) -and translate_return (meta : Meta.meta) (ectx : C.eval_ctx) (opt_v : V.typed_value option) +and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) (ctx : bs_ctx) : texpression = (* There are two cases: - either we reach the return of a forward function or a forward loop body, @@ -2012,16 +2015,16 @@ and translate_return (meta : Meta.meta) (ectx : C.eval_ctx) (opt_v : V.typed_val | None -> (* Forward function *) let v = Option.get opt_v in - typed_value_to_texpression meta ctx ectx v + typed_value_to_texpression ctx ectx v | Some _ -> (* Backward function *) (* Sanity check *) - assert (opt_v = None); + cassert (opt_v = None) ctx.fun_decl.meta "TODO: Error message"; (* Group the variables in which we stored the values we need to give back. See the explanations for the [SynthInput] case in [translate_end_abstraction] *) let backward_outputs = Option.get ctx.backward_outputs in let field_values = List.map mk_texpression_from_var backward_outputs in - mk_simpl_tuple_texpression field_values + mk_simpl_tuple_texpression ctx.fun_decl.meta field_values in (* We may need to return a state * - error-monad: Return x @@ -2031,17 +2034,17 @@ and translate_return (meta : Meta.meta) (ectx : C.eval_ctx) (opt_v : V.typed_val let output = if effect_info.stateful then let state_rvalue = mk_state_texpression ctx.state_var in - mk_simpl_tuple_texpression [ state_rvalue; output ] + mk_simpl_tuple_texpression ctx.fun_decl.meta [ state_rvalue; output ] else output in (* Wrap in a result - TODO: check effect_info.can_fail to not always wrap *) - mk_result_return_texpression output + mk_result_return_texpression ctx.fun_decl.meta output and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) (ctx : bs_ctx) : texpression = - assert (is_continue = ctx.inside_loop); + cassert (is_continue = ctx.inside_loop) ctx.fun_decl.meta "TODO: error message"; let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - assert (loop_id = Option.get ctx.loop_id); + cassert (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta "TODO: error message"; (* Lookup the loop information *) let loop_id = Option.get ctx.loop_id in @@ -2065,7 +2068,7 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) match ctx.backward_outputs with Some outputs -> outputs | None -> [] in let field_values = List.map mk_texpression_from_var backward_outputs in - mk_simpl_tuple_texpression field_values + mk_simpl_tuple_texpression ctx.fun_decl.meta field_values in (* We may need to return a state @@ -2079,13 +2082,13 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) let output = if effect_info.stateful then let state_rvalue = mk_state_texpression ctx.state_var in - mk_simpl_tuple_texpression [ state_rvalue; output ] + mk_simpl_tuple_texpression ctx.fun_decl.meta [ state_rvalue; output ] else output in (* Wrap in a result - TODO: check effect_info.can_fail to not always wrap *) - mk_emeta (Tag "return_with_loop") (mk_result_return_texpression output) + mk_emeta (Tag "return_with_loop") (mk_result_return_texpression ctx.fun_decl.meta output) -and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression) (ctx : bs_ctx) : +and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : texpression = log#ldebug (lazy @@ -2094,9 +2097,9 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression ^ "\n\n- call.generics:\n" ^ ctx_generic_args_to_string ctx call.generics)); (* Translate the function call *) - let generics = ctx_translate_fwd_generic_args meta ctx call.generics in + let generics = ctx_translate_fwd_generic_args ctx call.generics in let args = - let args = List.map (typed_value_to_texpression meta ctx call.ctx) call.args in + let args = List.map (typed_value_to_texpression ctx call.ctx) call.args in let args_mplaces = List.map translate_opt_mplace call.args_places in List.map (fun (arg, mp) -> mk_opt_mplace_texpression mp arg) @@ -2109,11 +2112,11 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression match call.call_id with | S.Fun (fid, call_id) -> (* Regular function call *) - let fid_t = translate_fun_id_or_trait_method_ref meta ctx fid in + let fid_t = translate_fun_id_or_trait_method_ref ctx fid in let func = Fun (FromLlbc (fid_t, None)) in (* Retrieve the effect information about this function (can fail, * takes a state as input, etc.) *) - let effect_info = get_fun_effect_info meta ctx fid None None in + let effect_info = get_fun_effect_info ctx fid None None in (* Depending on the function effects: - add the fuel - add the state input argument @@ -2134,7 +2137,7 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression let sg = Option.get call.sg in let decls_ctx = ctx.decls_ctx in let dsg = - translate_fun_sig_with_regions_hierarchy_to_decomposed meta decls_ctx fid + translate_fun_sig_with_regions_hierarchy_to_decomposed ctx.fun_decl.meta decls_ctx fid call.regions_hierarchy sg (List.map (fun _ -> None) sg.inputs) in @@ -2145,10 +2148,10 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression | None -> (UnknownTrait __FUNCTION__, generics) | Some (all_generics, tr_self) -> let all_generics = - ctx_translate_fwd_generic_args meta ctx all_generics + ctx_translate_fwd_generic_args ctx all_generics in let tr_self = - translate_fwd_trait_instance_id meta ctx.type_ctx.type_infos + translate_fwd_trait_instance_id ctx.fun_decl.meta ctx.type_ctx.type_infos tr_self in (tr_self, all_generics) @@ -2180,7 +2183,7 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression | PeIdent (s, _) -> s | PeImpl _ -> (* We shouldn't get there *) - craise meta "Unexpected") + craise decl.meta "Unexpected") in name ^ "_back" in @@ -2226,7 +2229,7 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression (ctx, dsg.fwd_info.ignore_output, Some back_funs_map, back_funs) in (* Compute the pattern for the destination *) - let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in let dest = (* Here there is something subtle: as we might ignore the output @@ -2263,13 +2266,13 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression is_rec = false; } in - let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop Not, effect_info, args, dest) | S.Unop E.Neg -> ( match args with | [ arg ] -> - let int_ty = ty_as_integer arg.ty in + let int_ty = ty_as_integer ctx.fun_decl.meta arg.ty in (* Note that negation can lead to an overflow and thus fail (it * is thus monadic) *) let effect_info = @@ -2281,10 +2284,10 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression is_rec = false; } in - let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Neg int_ty), effect_info, args, dest) - | _ -> craise meta "Unreachable") + | _ -> craise ctx.fun_decl.meta "Unreachable") | S.Unop (E.Cast cast_kind) -> ( match cast_kind with | CastScalar (src_ty, tgt_ty) -> @@ -2298,19 +2301,19 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression is_rec = false; } in - let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, dest) - | CastFnPtr _ -> craise meta "TODO: function casts") + | CastFnPtr _ -> craise ctx.fun_decl.meta "TODO: function casts") | S.Binop binop -> ( match args with | [ arg0; arg1 ] -> - let int_ty0 = ty_as_integer arg0.ty in - let int_ty1 = ty_as_integer arg1.ty in + let int_ty0 = ty_as_integer ctx.fun_decl.meta arg0.ty in + let int_ty1 = ty_as_integer ctx.fun_decl.meta arg1.ty in (match binop with (* The Rust compiler accepts bitshifts for any integer type combination for ty0, ty1 *) | E.Shl | E.Shr -> () - | _ -> assert (int_ty0 = int_ty1)); + | _ -> cassert (int_ty0 = int_ty1) ctx.fun_decl.meta "TODO: error message"); let effect_info = { can_fail = ExpressionsUtils.binop_can_fail binop; @@ -2320,10 +2323,10 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression is_rec = false; } in - let ctx, dest = fresh_var_for_symbolic_value meta call.dest ctx in + let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Binop (binop, int_ty0), effect_info, args, dest) - | _ -> craise meta "Unreachable") + | _ -> craise ctx.fun_decl.meta "Unreachable") in let func = { id = FunOrOp fun_id; generics } in let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in @@ -2332,13 +2335,13 @@ and translate_function_call (meta : Meta.meta) (call : S.call) (e : S.expression in let func_ty = mk_arrows input_tys ret_ty in let func = { e = Qualif func; ty = func_ty } in - let call = mk_apps func args in + let call = mk_apps ctx.fun_decl.meta func args in (* Translate the next expression *) - let next_e = translate_expression meta e ctx in + let next_e = translate_expression e ctx in (* Put together *) mk_let effect_info.can_fail dest_v call next_e -and translate_end_abstraction (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) : texpression = log#ldebug (lazy @@ -2346,15 +2349,15 @@ and translate_end_abstraction (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.ab ^ V.show_abs_kind abs.kind)); match abs.kind with | V.SynthInput rg_id -> - translate_end_abstraction_synth_input meta ectx abs e ctx rg_id + translate_end_abstraction_synth_input ectx abs e ctx rg_id | V.FunCall (call_id, rg_id) -> - translate_end_abstraction_fun_call meta ectx abs e ctx call_id rg_id - | V.SynthRet rg_id -> translate_end_abstraction_synth_ret meta ectx abs e ctx rg_id + translate_end_abstraction_fun_call ectx abs e ctx call_id rg_id + | V.SynthRet rg_id -> translate_end_abstraction_synth_ret ectx abs e ctx rg_id | V.Loop (loop_id, rg_id, abs_kind) -> - translate_end_abstraction_loop meta ectx abs e ctx loop_id rg_id abs_kind - | V.Identity -> translate_end_abstraction_identity meta ectx abs e ctx + translate_end_abstraction_loop ectx abs e ctx loop_id rg_id abs_kind + | V.Identity -> translate_end_abstraction_identity ectx abs e ctx -and translate_end_abstraction_synth_input (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) (rg_id : T.RegionGroupId.id) : texpression = log#ldebug @@ -2365,7 +2368,7 @@ and translate_end_abstraction_synth_input (meta : Meta.meta) (ectx : C.eval_ctx) ^ T.RegionGroupId.to_string rg_id ^ "\n- loop_id: " ^ Print.option_to_string Pure.LoopId.to_string ctx.loop_id - ^ "\n- eval_ctx:\n" ^ eval_ctx_to_string ectx ^ "\n- abs:\n" + ^ "\n- eval_ctx:\n" ^ eval_ctx_to_string ctx.fun_decl.meta ectx ^ "\n- abs:\n" ^ abs_to_string ctx abs ^ "\n")); (* When we end an input abstraction, this input abstraction gets back @@ -2379,7 +2382,7 @@ and translate_end_abstraction_synth_input (meta : Meta.meta) (ectx : C.eval_ctx) for a parent backward function. *) let bid = Option.get ctx.bid in - assert (rg_id = bid); + cassert (rg_id = bid) ctx.fun_decl.meta "TODO: error message"; (* First, introduce the given back variables. @@ -2404,7 +2407,7 @@ and translate_end_abstraction_synth_input (meta : Meta.meta) (ectx : C.eval_ctx) in (* Get the list of values consumed by the abstraction upon ending *) - let consumed_values = abs_to_consumed meta ctx ectx abs in + let consumed_values = abs_to_consumed ctx ectx abs in log#ldebug (lazy @@ -2426,10 +2429,10 @@ and translate_end_abstraction_synth_input (meta : Meta.meta) (ectx : C.eval_ctx) (* TODO: normalize the types *) if !Config.type_check_pure_code then List.iter - (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) + (fun (var, v) -> cassert ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta "TODO: error message") variables_values; (* Translate the next expression *) - let next_e = translate_expression meta e ctx in + let next_e = translate_expression e ctx in (* Generate the assignemnts *) let monadic = false in List.fold_right @@ -2437,7 +2440,7 @@ and translate_end_abstraction_synth_input (meta : Meta.meta) (ectx : C.eval_ctx) mk_let monadic (mk_typed_pattern_from_var var None) value e) variables_values next_e -and translate_end_abstraction_fun_call (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) (call_id : V.FunCallId.id) (rg_id : T.RegionGroupId.id) : texpression = let call_info = V.FunCallId.Map.find call_id ctx.calls in @@ -2447,12 +2450,12 @@ and translate_end_abstraction_fun_call (meta : Meta.meta) (ectx : C.eval_ctx) (a | S.Fun (fun_id, _) -> fun_id | Unop _ | Binop _ -> (* Those don't have backward functions *) - craise meta "Unreachable" + craise ctx.fun_decl.meta "Unreachable" in let effect_info = get_fun_effect_info ctx fun_id None (Some rg_id) in (* Retrieve the values consumed upon ending the loans inside this * abstraction: those give us the remaining input values *) - let back_inputs = abs_to_consumed meta ctx ectx abs in + let back_inputs = abs_to_consumed ctx ectx abs in (* If the function is stateful: * - add the state input argument * - generate a fresh state variable for the returned state @@ -2472,7 +2475,7 @@ and translate_end_abstraction_fun_call (meta : Meta.meta) (ectx : C.eval_ctx) (a let output_mpl = List.append (List.map translate_opt_mplace call.args_places) [ None ] in - let ctx, outputs = abs_to_given_back meta (Some output_mpl) abs ctx in + let ctx, outputs = abs_to_given_back (Some output_mpl) abs ctx in (* Group the output values together: first the updated inputs *) let output = mk_simpl_tuple_pattern outputs in (* Add the returned state if the function is stateful *) @@ -2484,10 +2487,10 @@ and translate_end_abstraction_fun_call (meta : Meta.meta) (ectx : C.eval_ctx) (a (* Retrieve the function id, and register the function call in the context if necessary.Arith_status *) let ctx, func = - bs_ctx_register_backward_call meta abs call_id rg_id back_inputs ctx + bs_ctx_register_backward_call abs call_id rg_id back_inputs ctx in (* Translate the next expression *) - let next_e = translate_expression meta e ctx in + let next_e = translate_expression e ctx in (* Put everything together *) let inputs = back_inputs in let args_mplaces = List.map (fun _ -> None) inputs in @@ -2512,21 +2515,21 @@ and translate_end_abstraction_fun_call (meta : Meta.meta) (ectx : C.eval_ctx) (a let call = mk_apps func args in mk_let effect_info.can_fail output call next_e -and translate_end_abstraction_identity (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_identity (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) : texpression = (* We simply check that the abstraction only contains shared borrows/loans, and translate the next expression *) (* We can do this simply by checking that it consumes and gives back nothing *) - let inputs = abs_to_consumed meta ctx ectx abs in - let ctx, outputs = abs_to_given_back meta None abs ctx in - assert (inputs = []); - assert (outputs = []); + let inputs = abs_to_consumed ctx ectx abs in + let ctx, outputs = abs_to_given_back None abs ctx in + cassert (inputs = []) ctx.fun_decl.meta "TODO: error message"; + cassert (outputs = []) ctx.fun_decl.meta "TODO: error message"; (* Translate the next expression *) - translate_expression meta e ctx + translate_expression e ctx -and translate_end_abstraction_synth_ret (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) (rg_id : T.RegionGroupId.id) : texpression = (* If we end the abstraction which consumed the return value of the function @@ -2562,13 +2565,13 @@ and translate_end_abstraction_synth_ret (meta : Meta.meta) (ectx : C.eval_ctx) ( let inputs = T.RegionGroupId.Map.find rg_id ctx.backward_inputs_no_state in (* Retrieve the values consumed upon ending the loans inside this * abstraction: as there are no nested borrows, there should be none. *) - let consumed = abs_to_consumed meta ctx ectx abs in - assert (consumed = []); + let consumed = abs_to_consumed ctx ectx abs in + cassert (consumed = []) ctx.fun_decl.meta "Nested borrows are not supported yet TODO: error message"; (* Retrieve the values given back upon ending this abstraction - note that * we don't provide meta-place information, because those assignments will * be inlined anyway... *) log#ldebug (lazy ("abs: " ^ abs_to_string ctx abs)); - let ctx, given_back = abs_to_given_back_no_mp meta abs ctx in + let ctx, given_back = abs_to_given_back_no_mp abs ctx in (* Link the inputs to those given back values - note that this also * checks we have the same number of values, of course *) let given_back_inputs = List.combine given_back inputs in @@ -2581,10 +2584,10 @@ and translate_end_abstraction_synth_ret (meta : Meta.meta) (ectx : C.eval_ctx) ( ^ pure_ty_to_string ctx given_back.ty ^ "\n- sig input ty: " ^ pure_ty_to_string ctx input.ty)); - assert (given_back.ty = input.ty)) + cassert (given_back.ty = input.ty) ctx.fun_decl.meta "TODO: error message") given_back_inputs; (* Translate the next expression *) - let next_e = translate_expression meta e ctx in + let next_e = translate_expression e ctx in (* Generate the assignments *) let monadic = false in List.fold_right @@ -2592,26 +2595,26 @@ and translate_end_abstraction_synth_ret (meta : Meta.meta) (ectx : C.eval_ctx) ( mk_let monadic given_back (mk_texpression_from_var input_var) e) given_back_inputs next_e -and translate_end_abstraction_loop (meta : Meta.meta) (ectx : C.eval_ctx) (abs : V.abs) +and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (e : S.expression) (ctx : bs_ctx) (loop_id : V.LoopId.id) (rg_id : T.RegionGroupId.id option) (abs_kind : V.loop_abs_kind) : texpression = let vloop_id = loop_id in let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - assert (loop_id = Option.get ctx.loop_id); + cassert (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta "TODO: error message"; let rg_id = Option.get rg_id in (* There are two cases depending on the [abs_kind] (whether this is a synth input or a regular loop call) *) match abs_kind with | V.LoopSynthInput -> (* Actually the same case as [SynthInput] *) - translate_end_abstraction_synth_input meta ectx abs e ctx rg_id + translate_end_abstraction_synth_input ectx abs e ctx rg_id | V.LoopCall -> ( (* We need to introduce a call to the backward function corresponding to a forward call which happened earlier *) let fun_id = E.FRegular ctx.fun_decl.def_id in let effect_info = - get_fun_effect_info meta ctx (FunId fun_id) (Some vloop_id) (Some rg_id) + get_fun_effect_info ctx (FunId fun_id) (Some vloop_id) (Some rg_id) in let loop_info = LoopId.Map.find loop_id ctx.loops in (* Retrieve the additional backward inputs. Note that those are actually @@ -2637,7 +2640,7 @@ and translate_end_abstraction_loop (meta : Meta.meta) (ectx : C.eval_ctx) (abs : (* Concatenate all the inputs *) let inputs = List.concat [ back_inputs; back_state ] in (* Retrieve the values given back by this function *) - let ctx, outputs = abs_to_given_back meta None abs ctx in + let ctx, outputs = abs_to_given_back None abs ctx in (* Group the output values together: first the updated inputs *) let output = mk_simpl_tuple_pattern outputs in (* Add the returned state if the function is stateful *) @@ -2647,7 +2650,7 @@ and translate_end_abstraction_loop (meta : Meta.meta) (ectx : C.eval_ctx) (abs : | Some nstate -> mk_simpl_tuple_pattern [ nstate; output ] in (* Translate the next expression *) - let next_e = translate_expression meta e ctx in + let next_e = translate_expression e ctx in (* Put everything together *) let args_mplaces = List.map (fun _ -> None) inputs in let args = @@ -2684,7 +2687,7 @@ and translate_end_abstraction_loop (meta : Meta.meta) (ectx : C.eval_ctx) (abs : *) let next_e = if ctx.inside_loop then - let consumed_values = abs_to_consumed meta ctx ectx abs in + let consumed_values = abs_to_consumed ctx ectx abs in let var_values = List.combine outputs consumed_values in let var_values = List.filter_map @@ -2702,36 +2705,36 @@ and translate_end_abstraction_loop (meta : Meta.meta) (ectx : C.eval_ctx) (abs : (* Create the let-binding *) mk_let effect_info.can_fail output call next_e) -and translate_global_eval (meta : Meta.meta) (gid : A.GlobalDeclId.id) (generics : T.generic_args) +and translate_global_eval (gid : A.GlobalDeclId.id) (generics : T.generic_args) (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) : texpression = - let ctx, var = fresh_var_for_symbolic_value meta sval ctx in + let ctx, var = fresh_var_for_symbolic_value sval ctx in let decl = A.GlobalDeclId.Map.find gid ctx.global_ctx.llbc_global_decls in let generics = ctx_translate_fwd_generic_args ctx generics in let global_expr = { id = Global gid; generics } in (* We use translate_fwd_ty to translate the global type *) - let ty = ctx_translate_fwd_ty meta ctx decl.ty in + let ty = ctx_translate_fwd_ty ctx decl.ty in let gval = { e = Qualif global_expr; ty } in - let e = translate_expression meta e ctx in + let e = translate_expression e ctx in mk_let false (mk_typed_pattern_from_var var None) gval e -and translate_assertion (meta : Meta.meta) (ectx : C.eval_ctx) (v : V.typed_value) +and translate_assertion (ectx : C.eval_ctx) (v : V.typed_value) (e : S.expression) (ctx : bs_ctx) : texpression = - let next_e = translate_expression meta e ctx in + let next_e = translate_expression e ctx in let monadic = true in - let v = typed_value_to_texpression meta ctx ectx v in + let v = typed_value_to_texpression ctx ectx v in let args = [ v ] in let func = { id = FunOrOp (Fun (Pure Assert)); generics = empty_generic_args } in let func_ty = mk_arrow (TLiteral TBool) mk_unit_ty in let func = { e = Qualif func; ty = func_ty } in - let assertion = mk_apps func args in + let assertion = mk_apps ctx.fun_decl.meta func args in mk_let monadic (mk_dummy_pattern mk_unit_ty) assertion next_e -and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symbolic_value) +and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) (exp : S.expansion) (ctx : bs_ctx) : texpression = (* Translate the scrutinee *) - let scrutinee = symbolic_value_to_texpression meta ctx sv in + let scrutinee = symbolic_value_to_texpression ctx sv in let scrutinee_mplace = translate_opt_mplace p in (* Translate the branches *) match exp with @@ -2740,12 +2743,12 @@ and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symboli | V.SeLiteral _ -> (* We do not *register* symbolic expansions to literal values in the symbolic ADT *) - craise meta "Unreachable" + craise ctx.fun_decl.meta "Unreachable" | SeMutRef (_, nsv) | SeSharedRef (_, nsv) -> (* The (mut/shared) borrow type is extracted to identity: we thus simply introduce an reassignment *) - let ctx, var = fresh_var_for_symbolic_value meta nsv ctx in - let next_e = translate_expression meta e ctx in + let ctx, var = fresh_var_for_symbolic_value nsv ctx in + let next_e = translate_expression e ctx in let monadic = false in mk_let monadic (mk_typed_pattern_from_var var None) @@ -2753,11 +2756,11 @@ and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symboli next_e | SeAdt _ -> (* Should be in the [ExpandAdt] case *) - craise meta "Unreachable") + craise ctx.fun_decl.meta "Unreachable") | ExpandAdt branches -> ( (* We don't do the same thing if there is a branching or not *) match branches with - | [] -> craise meta "Unreachable" + | [] -> craise ctx.fun_decl.meta "Unreachable" | [ (variant_id, svl, branch) ] when not (TypesUtils.ty_is_custom_adt sv.V.sv_ty @@ -2769,19 +2772,19 @@ and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symboli we *ignore* this branch (and go to the next one) if the ADT is a custom adt, and [always_deconstruct_adts_with_matches] is true. *) - translate_ExpandAdt_one_branch meta sv scrutinee scrutinee_mplace + translate_ExpandAdt_one_branch sv scrutinee scrutinee_mplace variant_id svl branch ctx | branches -> let translate_branch (variant_id : T.VariantId.id option) (svl : V.symbolic_value list) (branch : S.expression) : match_branch = - let ctx, vars = fresh_vars_for_symbolic_values meta svl ctx in + let ctx, vars = fresh_vars_for_symbolic_values svl ctx in let vars = List.map (fun x -> mk_typed_pattern_from_var x None) vars in let pat_ty = scrutinee.ty in let pat = mk_adt_pattern pat_ty variant_id vars in - let branch = translate_expression meta branch ctx in + let branch = translate_expression branch ctx in { pat; branch } in let branches = @@ -2796,14 +2799,14 @@ and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symboli let branch = List.hd branches in let ty = branch.branch.ty in (* Sanity check *) - assert (List.for_all (fun br -> br.branch.ty = ty) branches); + cassert (List.for_all (fun br -> br.branch.ty = ty) branches) ctx.fun_decl.meta "There should be at least one branch"; (* Return *) { e; ty }) | ExpandBool (true_e, false_e) -> (* We don't need to update the context: we don't introduce any new values/variables *) - let true_e = translate_expression meta true_e ctx in - let false_e = translate_expression meta false_e ctx in + let true_e = translate_expression true_e ctx in + let false_e = translate_expression false_e ctx in let e = Switch ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, @@ -2816,19 +2819,19 @@ and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symboli ^ pure_ty_to_string ctx true_e.ty ^ "\n\nfalse_e.ty: " ^ pure_ty_to_string ctx false_e.ty)); - if !Config.fail_hard then assert (ty = false_e.ty); + if !Config.fail_hard then cassert (ty = false_e.ty) ctx.fun_decl.meta "TODO: error message"; (* TODO: remove if ? *) { e; ty } | ExpandInt (int_ty, branches, otherwise) -> let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : match_branch = (* We don't need to update the context: we don't introduce any new values/variables *) - let branch = translate_expression meta branch_e ctx in + let branch = translate_expression branch_e ctx in let pat = mk_typed_pattern_from_literal (VScalar v) in { pat; branch } in let branches = List.map translate_branch branches in - let otherwise = translate_expression meta otherwise ctx in + let otherwise = translate_expression otherwise ctx in let pat_ty = TLiteral (TInteger int_ty) in let otherwise_pat : typed_pattern = { value = PatDummy; ty = pat_ty } in let otherwise : match_branch = @@ -2841,8 +2844,8 @@ and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symboli Match all_branches ) in let ty = otherwise.branch.ty in - assert ( - List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches); + cassert ( + List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) ctx.fun_decl.meta "TODO: error message"; { e; ty } (* Translate and [ExpandAdt] when there is no branching (i.e., one branch). @@ -2868,15 +2871,15 @@ and translate_expansion (meta : Meta.meta) (p : S.mplace option) (sv : V.symboli as inductives, in which case it is not always possible to use a notation for the field projections. *) -and translate_ExpandAdt_one_branch (meta : Meta.meta) (sv : V.symbolic_value) +and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (scrutinee : texpression) (scrutinee_mplace : mplace option) (variant_id : variant_id option) (svl : V.symbolic_value list) (branch : S.expression) (ctx : bs_ctx) : texpression = (* TODO: always introduce a match, and use micro-passes to turn the the match into a let? *) let type_id, _ = TypesUtils.ty_as_adt sv.V.sv_ty in - let ctx, vars = fresh_vars_for_symbolic_values meta svl ctx in - let branch = translate_expression meta branch ctx in + let ctx, vars = fresh_vars_for_symbolic_values svl ctx in + let branch = translate_expression branch ctx in match type_id with | TAdtId adt_id -> (* Detect if this is an enumeration or not *) @@ -2917,14 +2920,14 @@ and translate_ExpandAdt_one_branch (meta : Meta.meta) (sv : V.symbolic_value) * field. * We use the [dest] variable in order not to have to recompute * the type of the result of the projection... *) - let adt_id, generics = ty_as_adt scrutinee.ty in + let adt_id, generics = ty_as_adt ctx.fun_decl.meta scrutinee.ty in let gen_field_proj (field_id : FieldId.id) (dest : var) : texpression = let proj_kind = { adt_id; field_id } in let qualif = { id = Proj proj_kind; generics } in let proj_e = Qualif qualif in let proj_ty = mk_arrow scrutinee.ty dest.ty in let proj = { e = proj_e; ty = proj_ty } in - mk_app proj scrutinee + mk_app ctx.fun_decl.meta proj scrutinee in let id_var_pairs = FieldId.mapi (fun fid v -> (fid, v)) vars in let monadic = false in @@ -2943,7 +2946,7 @@ and translate_ExpandAdt_one_branch (meta : Meta.meta) (sv : V.symbolic_value) | TAssumed TBox -> (* There should be exactly one variable *) let var = - match vars with [ v ] -> v | _ -> craise meta "Unreachable" + match vars with [ v ] -> v | _ -> craise ctx.fun_decl.meta "Unreachable" in (* We simply introduce an assignment - the box type is the * identity when extracted ([box a = a]) *) @@ -2957,9 +2960,9 @@ and translate_ExpandAdt_one_branch (meta : Meta.meta) (sv : V.symbolic_value) * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number * of fields!) *) - craise meta "Attempt to expand a non-expandable value" + craise ctx.fun_decl.meta "Attempt to expand a non-expandable value" -and translate_intro_symbolic (meta : Meta.meta) (ectx : C.eval_ctx) (p : S.mplace option) +and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) (sv : V.symbolic_value) (v : S.value_aggregate) (e : S.expression) (ctx : bs_ctx) : texpression = log#ldebug @@ -2969,10 +2972,10 @@ and translate_intro_symbolic (meta : Meta.meta) (ectx : C.eval_ctx) (p : S.mplac let mplace = translate_opt_mplace p in (* Introduce a fresh variable for the symbolic value. *) - let ctx, var = fresh_var_for_symbolic_value meta sv ctx in + let ctx, var = fresh_var_for_symbolic_value sv ctx in (* Translate the next expression *) - let next_e = translate_expression meta e ctx in + let next_e = translate_expression e ctx in (* Translate the value: there are several cases, depending on whether this is a "regular" let-binding, an array aggregate, a const generic or @@ -2980,12 +2983,12 @@ and translate_intro_symbolic (meta : Meta.meta) (ectx : C.eval_ctx) (p : S.mplac *) let v = match v with - | VaSingleValue v -> typed_value_to_texpression meta ctx ectx v + | VaSingleValue v -> typed_value_to_texpression ctx ectx v | VaArray values -> (* We use a struct update to encode the array aggregate, in order to preserve the structure and allow generating code of the shape `[x0, ...., xn]` *) - let values = List.map (typed_value_to_texpression meta ctx ectx) values in + let values = List.map (typed_value_to_texpression ctx ectx) values in let values = FieldId.mapi (fun fid v -> (fid, v)) values in let su : struct_update = { struct_id = TAssumed TArray; init = None; updates = values } @@ -2994,7 +2997,7 @@ and translate_intro_symbolic (meta : Meta.meta) (ectx : C.eval_ctx) (p : S.mplac | VaCgValue cg_id -> { e = CVar cg_id; ty = var.ty } | VaTraitConstValue (trait_ref, const_name) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + let trait_ref = translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref in let qualif_id = TraitConst (trait_ref, const_name) in let qualif = { id = qualif_id; generics = empty_generic_args } in { e = Qualif qualif; ty = var.ty } @@ -3005,7 +3008,7 @@ and translate_intro_symbolic (meta : Meta.meta) (ectx : C.eval_ctx) (p : S.mplac let var = mk_typed_pattern_from_var var mplace in mk_let monadic var v next_e -and translate_forward_end (meta : Meta.meta) (ectx : C.eval_ctx) +and translate_forward_end (ectx : C.eval_ctx) (loop_input_values : V.typed_value S.symbolic_value_id_map option) (fwd_e : S.expression) (back_e : S.expression S.region_group_id_map) (ctx : bs_ctx) : texpression = @@ -3062,7 +3065,7 @@ and translate_forward_end (meta : Meta.meta) (ectx : C.eval_ctx) in (ctx, e, finish) in - let e = translate_expression meta e ctx in + let e = translate_expression e ctx in finish e in @@ -3135,7 +3138,7 @@ and translate_forward_end (meta : Meta.meta) (ectx : C.eval_ctx) else pure_fwd_var :: back_vars in let vars = List.map mk_texpression_from_var vars in - let ret = mk_simpl_tuple_texpression vars in + let ret = mk_simpl_tuple_texpression ctx.fun_decl.meta vars in (* Introduce a fresh input state variable for the forward expression *) let _ctx, state_var, state_pat = @@ -3146,8 +3149,8 @@ and translate_forward_end (meta : Meta.meta) (ectx : C.eval_ctx) in let state_var = List.map mk_texpression_from_var state_var in - let ret = mk_simpl_tuple_texpression (state_var @ [ ret ]) in - let ret = mk_result_return_texpression ret in + let ret = mk_simpl_tuple_texpression ctx.fun_decl.meta (state_var @ [ ret ]) in + let ret = mk_result_return_texpression ctx.fun_decl.meta ret in (* Introduce all the let-bindings *) @@ -3216,13 +3219,13 @@ and translate_forward_end (meta : Meta.meta) (ectx : C.eval_ctx) loop_info.input_svl in let args = - List.map (typed_value_to_texpression meta ctx ectx) loop_input_values + List.map (typed_value_to_texpression ctx ectx) loop_input_values in let org_args = args in (* Lookup the effect info for the loop function *) let fid = E.FRegular ctx.fun_decl.def_id in - let effect_info = get_fun_effect_info meta ctx (FunId fid) None ctx.bid in + let effect_info = get_fun_effect_info ctx (FunId fid) None ctx.bid in (* Introduce a fresh output value for the forward function *) let ctx, fwd_output, output_pat = @@ -3320,7 +3323,7 @@ and translate_forward_end (meta : Meta.meta) (ectx : C.eval_ctx) in let func_ty = mk_arrows input_tys ret_ty in let func = { e = Qualif func; ty = func_ty } in - let call = mk_apps func args in + let call = mk_apps ctx.fun_decl.meta func args in call in @@ -3342,7 +3345,7 @@ and translate_forward_end (meta : Meta.meta) (ectx : C.eval_ctx) *) mk_emeta_symbolic_assignments loop_info.input_vars org_args e -and translate_loop (meta : Meta.meta) (loop : S.loop) (ctx : bs_ctx) : texpression = +and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = let loop_id = V.LoopId.Map.find loop.loop_id ctx.loop_ids_map in (* Translate the loop inputs - some inputs are symbolic values already @@ -3369,16 +3372,16 @@ and translate_loop (meta : Meta.meta) (loop : S.loop) (ctx : bs_ctx) : texpressi (Print.list_to_string (ty_to_string ctx)) loop.rg_to_given_back_tys ^ "\n")); - let ctx, _ = fresh_vars_for_symbolic_values meta svl ctx in + let ctx, _ = fresh_vars_for_symbolic_values svl ctx in ctx in (* Sanity check: all the non-fresh symbolic values are in the context *) - assert ( + cassert ( List.for_all (fun (sv : V.symbolic_value) -> V.SymbolicValueId.Map.mem sv.sv_id ctx.sv_to_var) - loop.input_svalues); + loop.input_svalues) ctx.fun_decl.meta "All the non-fresh symbolic values should be in the context"; (* Translate the loop inputs *) let inputs = @@ -3398,8 +3401,8 @@ and translate_loop (meta : Meta.meta) (loop : S.loop) (ctx : bs_ctx) : texpressi (* The types shouldn't contain borrows - we can translate them as forward types *) List.map (fun ty -> - assert (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)); - ctx_translate_fwd_ty meta !ctx ty) + cassert (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)) !ctx.fun_decl.meta "The types shouldn't contain borrows"; + ctx_translate_fwd_ty !ctx ty) tys) loop.rg_to_given_back_tys in @@ -3477,7 +3480,7 @@ and translate_loop (meta : Meta.meta) (loop : S.loop) (ctx : bs_ctx) : texpressi (* Add the loop information in the context *) let ctx = - assert (not (LoopId.Map.mem loop_id ctx.loops)); + cassert (not (LoopId.Map.mem loop_id ctx.loops)) ctx.fun_decl.meta "The loop information should not already be in the context TODO: error message"; (* Note that we will retrieve the input values later in the [ForwardEnd] (and will introduce the outputs at that moment, together with the actual @@ -3526,7 +3529,7 @@ and translate_loop (meta : Meta.meta) (loop : S.loop) (ctx : bs_ctx) : texpressi (* Update the context to translate the function end *) let ctx_end = { ctx with loop_id = Some loop_id } in - let fun_end = translate_expression meta loop.end_expr ctx_end in + let fun_end = translate_expression loop.end_expr ctx_end in (* Update the context for the loop body *) let ctx_loop = { ctx_end with inside_loop = true } in @@ -3537,7 +3540,7 @@ and translate_loop (meta : Meta.meta) (loop : S.loop) (ctx : bs_ctx) : texpressi in (* Translate the loop body *) - let loop_body = translate_expression meta loop.loop_expr ctx_loop in + let loop_body = translate_expression loop.loop_expr ctx_loop in (* Create the loop node and return *) let loop = @@ -3558,14 +3561,14 @@ and translate_loop (meta : Meta.meta) (loop : S.loop) (ctx : bs_ctx) : texpressi let ty = fun_end.ty in { e = loop; ty } -and translate_emeta (metadata : Meta.meta) (meta : S.emeta) (e : S.expression) (ctx : bs_ctx) : +and translate_emeta (meta : S.emeta) (e : S.expression) (ctx : bs_ctx) : texpression = - let next_e = translate_expression metadata e ctx in + let next_e = translate_expression e ctx in let meta = match meta with | S.Assignment (ectx, lp, rv, rp) -> let lp = translate_mplace lp in - let rv = typed_value_to_texpression metadata ctx ectx rv in + let rv = typed_value_to_texpression ctx ectx rv in let rp = translate_opt_mplace rp in Some (Assignment (lp, rv, rp)) | S.Snapshot ectx -> @@ -3586,14 +3589,14 @@ and translate_emeta (metadata : Meta.meta) (meta : S.emeta) (e : S.expression) ( | None -> next_e (** Wrap a function body in a match over the fuel to control termination. *) -let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) +let wrap_in_match_fuel (meta : Meta.meta) (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) : texpression = let fuel0_var : var = mk_fuel_var fuel0 in let fuel0 = mk_texpression_from_var fuel0_var in let nfuel_var : var = mk_fuel_var fuel in let nfuel_pat = mk_typed_pattern_from_var nfuel_var None in let fail_branch = - mk_result_fail_texpression_with_error_id error_out_of_fuel_id body.ty + mk_result_fail_texpression_with_error_id meta error_out_of_fuel_id body.ty in match !Config.backend with | FStar -> @@ -3615,7 +3618,7 @@ let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) in let func_ty = mk_arrow mk_fuel_ty mk_bool_ty in let func = { e = Qualif func; ty = func_ty } in - mk_app func fuel0 + mk_app meta func fuel0 in (* Create the expression: [decrease fuel0] *) let decrease_fuel = @@ -3627,7 +3630,7 @@ let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) in let func_ty = mk_arrow mk_fuel_ty mk_fuel_ty in let func = { e = Qualif func; ty = func_ty } in - mk_app func fuel0 + mk_app meta func fuel0 in (* Create the success branch *) @@ -3664,7 +3667,7 @@ let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) (* We should have checked the command line arguments before *) raise (Failure "Unexpected") -let translate_fun_decl (meta : Meta.meta) (ctx : bs_ctx) (body : S.expression option) : fun_decl = +let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (* Translate *) let def = ctx.fun_decl in assert (ctx.bid = None); @@ -3679,24 +3682,24 @@ let translate_fun_decl (meta : Meta.meta) (ctx : bs_ctx) (body : S.expression op let llbc_name = def.name in let name = name_to_string ctx llbc_name in (* Translate the signature *) - let signature = translate_fun_sig_from_decomposed ctx.sg in + let signature = translate_fun_sig_from_decomposed def.meta ctx.sg in (* Translate the body, if there is *) let body = match body with | None -> None | Some body -> let effect_info = - get_fun_effect_info meta ctx (FunId (FRegular def_id)) None None + get_fun_effect_info ctx (FunId (FRegular def_id)) None None in - let body = translate_expression meta body ctx in + let body = translate_expression body ctx in (* Add a match over the fuel, if necessary *) let body = if function_decreases_fuel effect_info then - wrap_in_match_fuel ctx.fuel0 ctx.fuel body + wrap_in_match_fuel def.meta ctx.fuel0 ctx.fuel body else body in (* Sanity check *) - type_check_texpression meta ctx body; + type_check_texpression ctx body; (* Introduce the fuel parameter, if necessary *) let fuel = if function_uses_fuel effect_info then @@ -3733,10 +3736,10 @@ let translate_fun_decl (meta : Meta.meta) (ctx : bs_ctx) (body : S.expression op (List.map (pure_ty_to_string ctx) signature.inputs))); (* TODO: we need to normalize the types *) if !Config.type_check_pure_code then - assert ( + cassert ( List.for_all (fun (var, ty) -> (var : var).ty = ty) - (List.combine inputs signature.inputs)); + (List.combine inputs signature.inputs)) def.meta "TODO: error message"; Some { inputs; inputs_lvs; body } in @@ -3771,11 +3774,11 @@ let translate_fun_decl (meta : Meta.meta) (ctx : bs_ctx) (body : S.expression op (* return *) def -let translate_type_decls (meta : Meta.meta) (ctx : Contexts.decls_ctx) : type_decl list = - List.map (translate_type_decl meta ctx) +let translate_type_decls (ctx : Contexts.decls_ctx) : type_decl list = + List.map (translate_type_decl ctx) (TypeDeclId.Map.values ctx.type_ctx.type_decls) -let translate_trait_decl (metadata : Meta.meta) (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) +let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) : trait_decl = let { def_id; @@ -3798,20 +3801,20 @@ let translate_trait_decl (metadata : Meta.meta) (ctx : Contexts.decls_ctx) (trai (Print.Contexts.decls_ctx_to_fmt_env ctx) llbc_name in - let generics = translate_generic_params metadata llbc_generics in - let preds = translate_predicates metadata preds in - let parent_clauses = List.map (translate_trait_clause metadata) llbc_parent_clauses in + let generics = translate_generic_params trait_decl.meta llbc_generics in + let preds = translate_predicates trait_decl.meta preds in + let parent_clauses = List.map (translate_trait_clause trait_decl.meta) llbc_parent_clauses in let consts = List.map - (fun (name, (ty, id)) -> (name, (translate_fwd_ty metadata type_infos ty, id))) + (fun (name, (ty, id)) -> (name, (translate_fwd_ty trait_decl.meta type_infos ty, id))) consts in let types = List.map (fun (name, (trait_clauses, ty)) -> ( name, - ( List.map (translate_trait_clause metadata) trait_clauses, - Option.map (translate_fwd_ty metadata type_infos) ty ) )) + ( List.map (translate_trait_clause trait_decl.meta) trait_clauses, + Option.map (translate_fwd_ty trait_decl.meta type_infos) ty ) )) types in { @@ -3831,7 +3834,7 @@ let translate_trait_decl (metadata : Meta.meta) (ctx : Contexts.decls_ctx) (trai provided_methods; } -let translate_trait_impl (metadata : Meta.meta) (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) +let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) : trait_impl = let { A.def_id; @@ -3851,27 +3854,27 @@ let translate_trait_impl (metadata : Meta.meta) (ctx : Contexts.decls_ctx) (trai in let type_infos = ctx.type_ctx.type_infos in let impl_trait = - translate_trait_decl_ref metadata (translate_fwd_ty metadata type_infos) llbc_impl_trait + translate_trait_decl_ref trait_impl.meta (translate_fwd_ty trait_impl.meta type_infos) llbc_impl_trait in let name = Print.Types.name_to_string (Print.Contexts.decls_ctx_to_fmt_env ctx) llbc_name in - let generics = translate_generic_params metadata llbc_generics in - let preds = translate_predicates metadata preds in - let parent_trait_refs = List.map (translate_strait_ref metadata) parent_trait_refs in + let generics = translate_generic_params trait_impl.meta llbc_generics in + let preds = translate_predicates trait_impl.meta preds in + let parent_trait_refs = List.map (translate_strait_ref trait_impl.meta) parent_trait_refs in let consts = List.map - (fun (name, (ty, id)) -> (name, (translate_fwd_ty metadata type_infos ty, id))) + (fun (name, (ty, id)) -> (name, (translate_fwd_ty trait_impl.meta type_infos ty, id))) consts in let types = List.map (fun (name, (trait_refs, ty)) -> ( name, - ( List.map (translate_fwd_trait_ref metadata type_infos) trait_refs, - translate_fwd_ty metadata type_infos ty ) )) + ( List.map (translate_fwd_trait_ref trait_impl.meta type_infos) trait_refs, + translate_fwd_ty trait_impl.meta type_infos ty ) )) types in { diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 43d2fbb0..2ee1324b 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -20,7 +20,7 @@ type symbolic_fun_translation = symbolic_value list * SA.expression (** Execute the symbolic interpreter on a function to generate a list of symbolic ASTs, for the forward function and the backward functions. *) -let translate_function_to_symbolics (meta : Meta.meta) (trans_ctx : trans_ctx) (fdef : fun_decl) : +let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : fun_decl) : symbolic_fun_translation option = (* Debug *) log#ldebug @@ -32,7 +32,7 @@ let translate_function_to_symbolics (meta : Meta.meta) (trans_ctx : trans_ctx) ( | Some _ -> (* Evaluate *) let synthesize = true in - let inputs, symb = evaluate_function_symbolic meta synthesize trans_ctx fdef in + let inputs, symb = evaluate_function_symbolic synthesize trans_ctx fdef in Some (inputs, Option.get symb) (** Translate a function, by generating its forward and backward translations. @@ -41,7 +41,7 @@ let translate_function_to_symbolics (meta : Meta.meta) (trans_ctx : trans_ctx) ( of backward functions, we also provide names for the outputs. TODO: maybe we should introduce a record for this. *) -let translate_function_to_pure (meta : Meta.meta) (trans_ctx : trans_ctx) +let translate_function_to_pure (trans_ctx : trans_ctx) (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fun_dsigs : Pure.decomposed_fun_sig FunDeclId.Map.t) (fdef : fun_decl) : pure_fun_translation_no_loops = @@ -50,7 +50,7 @@ let translate_function_to_pure (meta : Meta.meta) (trans_ctx : trans_ctx) (lazy ("translate_function_to_pure: " ^ name_to_string trans_ctx fdef.name)); (* Compute the symbolic ASTs, if the function is transparent *) - let symbolic_trans = translate_function_to_symbolics meta trans_ctx fdef in + let symbolic_trans = translate_function_to_symbolics trans_ctx fdef in (* Convert the symbolic ASTs to pure ASTs: *) @@ -176,7 +176,7 @@ let translate_function_to_pure (meta : Meta.meta) (trans_ctx : trans_ctx) SymbolicToPure.fresh_named_vars_for_symbolic_values input_svs ctx in { ctx with forward_inputs } - | _ -> craise meta "Unreachable" + | _ -> craise fdef.meta "Unreachable" in (* Add the backward inputs *) @@ -195,7 +195,7 @@ let translate_function_to_pure (meta : Meta.meta) (trans_ctx : trans_ctx) | Some (_, ast) -> SymbolicToPure.translate_fun_decl ctx (Some ast) (* TODO: factor out the return type *) -let translate_crate_to_pure (meta : Meta.meta) (crate : crate) : +let translate_crate_to_pure (crate : crate) : trans_ctx * Pure.type_decl list * pure_fun_translation list @@ -208,7 +208,7 @@ let translate_crate_to_pure (meta : Meta.meta) (crate : crate) : let trans_ctx = compute_contexts crate in (* Translate all the type definitions *) - let type_decls = SymbolicToPure.translate_type_decls meta trans_ctx in + let type_decls = SymbolicToPure.translate_type_decls trans_ctx in (* Compute the type definition map *) let type_decls_map = @@ -222,7 +222,7 @@ let translate_crate_to_pure (meta : Meta.meta) (crate : crate) : (List.map (fun (fdef : LlbcAst.fun_decl) -> ( fdef.def_id, - SymbolicToPure.translate_fun_sig_from_decl_to_decomposed meta trans_ctx + SymbolicToPure.translate_fun_sig_from_decl_to_decomposed trans_ctx fdef )) (FunDeclId.Map.values crate.fun_decls)) in @@ -230,21 +230,21 @@ let translate_crate_to_pure (meta : Meta.meta) (crate : crate) : (* Translate all the *transparent* functions *) let pure_translations = List.map - (translate_function_to_pure meta trans_ctx type_decls_map fun_dsigs) + (translate_function_to_pure trans_ctx type_decls_map fun_dsigs) (FunDeclId.Map.values crate.fun_decls) in (* Translate the trait declarations *) let trait_decls = List.map - (SymbolicToPure.translate_trait_decl meta trans_ctx) + (SymbolicToPure.translate_trait_decl trans_ctx) (TraitDeclId.Map.values trans_ctx.trait_decls_ctx.trait_decls) in (* Translate the trait implementations *) let trait_impls = List.map - (SymbolicToPure.translate_trait_impl meta trans_ctx) + (SymbolicToPure.translate_trait_impl trans_ctx) (TraitImplId.Map.values trans_ctx.trait_impls_ctx.trait_impls) in @@ -354,7 +354,7 @@ let export_type (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) *) let export_types_group (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (is_rec : bool) (ids : Pure.TypeDeclId.id list) : unit = - cassert (ids <> []) meta "TODO: Error message"; + assert (ids <> []) (* meta "TODO: Error message" *); let export_type = export_type fmt config ctx in let ids_set = Pure.TypeDeclId.Set.of_list ids in let export_type_decl kind id = export_type ids_set kind id true false in @@ -396,11 +396,11 @@ let export_types_group (meta : Meta.meta) (fmt : Format.formatter) (config : gen if List.exists (fun b -> b) builtin then (* Sanity check *) - cassert (List.for_all (fun b -> b) builtin) meta "TODO: Error message" + assert (List.for_all (fun b -> b) builtin) (* meta "TODO: Error message" *) else if List.exists dont_extract defs then (* Check if we have to ignore declarations *) (* Sanity check *) - cassert (List.for_all dont_extract defs) meta "TODO: Error message" + assert (List.for_all dont_extract defs) (* meta "TODO: Error message" *) else ( (* Extract the type declarations. @@ -442,13 +442,13 @@ let export_types_group (meta : Meta.meta) (fmt : Format.formatter) (config : gen TODO: check correct behavior with opaque globals. *) -let export_global (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) +let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (id : GlobalDeclId.id) : unit = let global_decls = ctx.trans_ctx.global_ctx.global_decls in let global = GlobalDeclId.Map.find id global_decls in let trans = FunDeclId.Map.find global.body ctx.trans_funs in - assert (trans.fwd.loops = []); - assert (trans.backs = []); + cassert (trans.fwd.loops = []) global.meta "TODO: Error message"; + cassert (trans.backs = []) global.meta "TODO: Error message"; let body = trans.fwd.f in let is_opaque = Option.is_none body.Pure.body in @@ -658,7 +658,7 @@ let export_trait_decl (fmt : Format.formatter) (_config : gen_config) let open ExtractBuiltin in if match_name_find_opt ctx.trans_ctx trait_decl.llbc_name - (builtin_trait_decls_map ()) + (builtin_trait_decls_map trait_decl.meta ()) = None then ( let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in @@ -702,7 +702,7 @@ let extract_definitions (meta : Meta.meta) (fmt : Format.formatter) (config : ge the [Arguments] information in Coq). *) let export_functions_group = export_functions_group meta fmt config ctx in - let export_global = export_global meta fmt config ctx in + let export_global = export_global fmt config ctx in let export_types_group = export_types_group meta fmt config ctx in let export_trait_decl_group id = export_trait_decl fmt config ctx id true false @@ -716,7 +716,7 @@ let extract_definitions (meta : Meta.meta) (fmt : Format.formatter) (config : ge let kind = if config.interface then ExtractBase.Declared else ExtractBase.Assumed in - Extract.extract_state_type fmt ctx kind + Extract.extract_state_type meta fmt ctx kind in let export_decl_group (dg : declaration_group) : unit = @@ -905,17 +905,17 @@ let extract_file (meta : Meta.meta) (config : gen_config) (ctx : gen_ctx) (fi : close_out out (** Translate a crate and write the synthesized code to an output file. *) -let translate_crate (meta : Meta.meta) (filename : string) (dest_dir : string) (crate : crate) : +let translate_crate (filename : string) (dest_dir : string) (crate : crate) : unit = (* Translate the module to the pure AST *) let trans_ctx, trans_types, trans_funs, trans_trait_decls, trans_trait_impls = - translate_crate_to_pure meta crate + translate_crate_to_pure crate in (* Initialize the names map by registering the keywords used in the language, as well as some primitive names ("u32", etc.). We insert the names of the local declarations later. *) - let names_maps = Extract.initialize_names_maps () in + let names_maps = Extract.initialize_names_maps () in (*TODO*) (* We need to compute which functions are recursive, in order to know * whether we should generate a decrease clause or not. *) @@ -1038,7 +1038,7 @@ let translate_crate (meta : Meta.meta) (filename : string) (dest_dir : string) ( match Filename.chop_suffix_opt ~suffix:".llbc" filename with | None -> (* Note that we already checked the suffix upon opening the file *) - craise meta "Unreachable" + raise (Failure "Unreachable") (* TODO check *) | Some filename -> (* Retrieve the file basename *) let basename = Filename.basename filename in @@ -1080,7 +1080,7 @@ let translate_crate (meta : Meta.meta) (filename : string) (dest_dir : string) ( let ( ^^ ) = Filename.concat in if !Config.split_files then mkdir_if (dest_dir ^^ crate_name); if needs_clauses_module then ( - cassert !Config.split_files meta "TODO: Error message"; + assert !Config.split_files (* meta "TODO: Error message META?" *); mkdir_if (dest_dir ^^ crate_name ^^ "Clauses"))); (* Copy the "Primitives" file, if necessary *) diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 12c20262..c4fcdb4a 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -1,5 +1,6 @@ open Types open LlbcAst +open Errors type subtype_info = { under_borrow : bool; (** Are we inside a borrow? *) @@ -288,7 +289,7 @@ let analyze_type_decl (updated : bool ref) (infos : type_infos) (List.map (fun v -> List.map (fun f -> f.field_ty) v.fields) variants) - | Opaque -> raise (Failure "unreachable") + | Opaque -> craise def.meta "unreachable" in (* Explore the types and accumulate information *) let type_decl_info = TypeDeclId.Map.find def.def_id infos in diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 2c7d213f..51c9e8cc 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -2,6 +2,7 @@ open Utils open TypesUtils open Types open Values +open Errors include Charon.ValuesUtils (** Utility exception *) @@ -10,34 +11,34 @@ exception FoundSymbolicValue of symbolic_value let mk_unit_value : typed_value = { value = VAdt { variant_id = None; field_values = [] }; ty = mk_unit_ty } -let mk_typed_value (ty : ty) (value : value) : typed_value = - assert (ty_is_ety ty); +let mk_typed_value (meta : Meta.meta) (ty : ty) (value : value) : typed_value = + cassert (ty_is_ety ty) meta "TODO: error message"; { value; ty } -let mk_typed_avalue (ty : ty) (value : avalue) : typed_avalue = - assert (ty_is_rty ty); +let mk_typed_avalue (meta : Meta.meta) (ty : ty) (value : avalue) : typed_avalue = + cassert (ty_is_rty ty) meta "TODO: error message"; { value; ty } -let mk_bottom (ty : ty) : typed_value = - assert (ty_is_ety ty); +let mk_bottom (meta : Meta.meta) (ty : ty) : typed_value = + cassert (ty_is_ety ty) meta "TODO: error message"; { value = VBottom; ty } -let mk_abottom (ty : ty) : typed_avalue = - assert (ty_is_rty ty); +let mk_abottom (meta : Meta.meta) (ty : ty) : typed_avalue = + cassert (ty_is_rty ty) meta "TODO: error message"; { value = ABottom; ty } -let mk_aignored (ty : ty) : typed_avalue = - assert (ty_is_rty ty); +let mk_aignored (meta : Meta.meta) (ty : ty) : typed_avalue = + cassert (ty_is_rty ty) meta "TODO: error message"; { value = AIgnored; ty } -let value_as_symbolic (v : value) : symbolic_value = - match v with VSymbolic v -> v | _ -> raise (Failure "Unexpected") +let value_as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = + match v with VSymbolic v -> v | _ -> craise meta "Unexpected" (** Box a value *) -let mk_box_value (v : typed_value) : typed_value = +let mk_box_value (meta : Meta.meta) (v : typed_value) : typed_value = let box_ty = mk_box_ty v.ty in let box_v = VAdt { variant_id = None; field_values = [ v ] } in - mk_typed_value box_ty box_v + mk_typed_value meta box_ty box_v let is_bottom (v : value) : bool = match v with VBottom -> true | _ -> false @@ -47,13 +48,13 @@ let is_aignored (v : avalue) : bool = let is_symbolic (v : value) : bool = match v with VSymbolic _ -> true | _ -> false -let as_symbolic (v : value) : symbolic_value = - match v with VSymbolic s -> s | _ -> raise (Failure "Unexpected") +let as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = + match v with VSymbolic s -> s | _ -> craise meta "Unexpected" -let as_mut_borrow (v : typed_value) : BorrowId.id * typed_value = +let as_mut_borrow (meta : Meta.meta) (v : typed_value) : BorrowId.id * typed_value = match v.value with | VBorrow (VMutBorrow (bid, bv)) -> (bid, bv) - | _ -> raise (Failure "Unexpected") + | _ -> craise meta "Unexpected" let is_unit (v : typed_value) : bool = ty_is_unit v.ty -- cgit v1.2.3 From 76fda6b5d205a4422c2360b676227690714c9ac5 Mon Sep 17 00:00:00 2001 From: Escherichia Date: Fri, 22 Mar 2024 15:59:22 +0100 Subject: Still need to fill the TODO: error message and check some meta but it builds --- compiler/Extract.ml | 4 +- compiler/ExtractBase.ml | 78 +++++++++--------- compiler/ExtractTypes.ml | 45 ++++++----- compiler/InterpreterLoopsCore.ml | 5 +- compiler/InterpreterLoopsMatchCtxs.ml | 146 ++++++++++++++++++---------------- compiler/InterpreterPaths.ml | 2 +- compiler/InterpreterStatements.ml | 2 +- compiler/PrintPure.ml | 24 +++--- compiler/SymbolicToPure.ml | 10 +-- compiler/Translate.ml | 48 +++++------ 10 files changed, 186 insertions(+), 178 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 246fc82f..3d0fe75f 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2381,7 +2381,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) clauses) @@ -2396,7 +2396,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) decl.parent_clauses; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index f6b891cc..18729af4 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -425,7 +425,7 @@ let names_maps_add (id_to_string : id -> string) (id : id) (name : string) (** The [id_to_string] function to print nice debugging messages if there are collisions *) -let names_maps_get (meta : Meta.meta) (id_to_string : id -> string) (id : id) (nm : names_maps) : +let names_maps_get ?(meta = None) (id_to_string : id -> string) (id : id) (nm : names_maps) : string = (* We do not use the same name map if we allow/disallow collisions *) let map_to_string (m : string IdMap.t) : string = @@ -446,7 +446,7 @@ let names_maps_get (meta : Meta.meta) (id_to_string : id -> string) (id : id) (n ^ map_to_string m in log#serror err; - if !Config.fail_hard then craise meta err + if !Config.fail_hard then craise_opt_meta meta err else "(%%%ERROR: unknown identifier\": " ^ id_to_string id ^ "\"%%%)") else let m = nm.names_map.id_to_name in @@ -458,7 +458,7 @@ let names_maps_get (meta : Meta.meta) (id_to_string : id -> string) (id : id) (n ^ map_to_string m in log#serror err; - if !Config.fail_hard then craise meta err + if !Config.fail_hard then craise_opt_meta meta err else "(ERROR: \"" ^ id_to_string id ^ "\")" type names_map_init = { @@ -591,17 +591,17 @@ let llbc_fun_id_to_string (ctx : extraction_ctx) = let fun_id_to_string (ctx : extraction_ctx) = PrintPure.regular_fun_id_to_string (extraction_ctx_to_fmt_env ctx) -let adt_variant_to_string (meta : Meta.meta) (ctx : extraction_ctx) = - PrintPure.adt_variant_to_string meta (extraction_ctx_to_fmt_env ctx) +let adt_variant_to_string ?(meta = None) (ctx : extraction_ctx) = + PrintPure.adt_variant_to_string ~meta:meta (extraction_ctx_to_fmt_env ctx) -let adt_field_to_string (meta : Meta.meta) (ctx : extraction_ctx) = - PrintPure.adt_field_to_string meta (extraction_ctx_to_fmt_env ctx) +let adt_field_to_string ?(meta = None) (ctx : extraction_ctx) = + PrintPure.adt_field_to_string ~meta:meta (extraction_ctx_to_fmt_env ctx) (** Debugging function, used when communicating name collisions to the user, and also to print ids for internal debugging (in case of lookup miss for instance). *) -let id_to_string (meta : Meta.meta) (id : id) (ctx : extraction_ctx) : string = +let id_to_string ?(meta = None) (id : id) (ctx : extraction_ctx) : string = let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = let trait_name = trait_decl_id_to_string ctx id in "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" @@ -629,11 +629,11 @@ let id_to_string (meta : Meta.meta) (id : id) (ctx : extraction_ctx) : string = | StructId id -> "struct constructor of: " ^ type_id_to_string ctx id | VariantId (id, variant_id) -> let type_name = type_id_to_string ctx id in - let variant_name = adt_variant_to_string meta ctx id (Some variant_id) in + let variant_name = adt_variant_to_string ~meta:meta ctx id (Some variant_id) in "type name: " ^ type_name ^ ", variant name: " ^ variant_name | FieldId (id, field_id) -> let type_name = type_id_to_string ctx id in - let field_name = adt_field_to_string meta ctx id field_id in + let field_name = adt_field_to_string ~meta:meta ctx id field_id in "type name: " ^ type_name ^ ", field name: " ^ field_name | UnknownId -> "keyword" | TypeVarId id -> "type_var_id: " ^ TypeVarId.to_string id @@ -660,54 +660,54 @@ let id_to_string (meta : Meta.meta) (id : id) (ctx : extraction_ctx) : string = | TraitSelfClauseId -> "trait_self_clause" let ctx_add (meta : Meta.meta) (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = - let id_to_string (id : id) : string = id_to_string meta id ctx in + let id_to_string (id : id) : string = id_to_string ~meta:(Some meta) id ctx in let names_maps = names_maps_add id_to_string id name ctx.names_maps in { ctx with names_maps } -let ctx_get (meta : Meta.meta) (id : id) (ctx : extraction_ctx) : string = - let id_to_string (id : id) : string = id_to_string meta id ctx in - names_maps_get meta id_to_string id ctx.names_maps (* TODO check if we can remove the meta arg, same for following functions*) +let ctx_get ?(meta = None) (id : id) (ctx : extraction_ctx) : string = + let id_to_string (id : id) : string = id_to_string ~meta:meta id ctx in + names_maps_get ~meta:meta id_to_string id ctx.names_maps (* TODO check if we can remove the meta arg, same for following functions*) let ctx_get_global (meta : Meta.meta) (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = - ctx_get meta (GlobalId id) ctx + ctx_get ~meta:(Some meta) (GlobalId id) ctx let ctx_get_function (meta : Meta.meta) (id : fun_id) (ctx : extraction_ctx) : string = - ctx_get meta (FunId id) ctx + ctx_get ~meta:(Some meta) (FunId id) ctx let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) (lp : LoopId.id option) (ctx : extraction_ctx) : string = ctx_get_function meta (FromLlbc (FunId (FRegular id), lp)) ctx -let ctx_get_type (meta : Meta.meta) (id : type_id) (ctx : extraction_ctx) : string = - cassert (id <> TTuple) meta "T"; - ctx_get meta (TypeId id) ctx +let ctx_get_type ?(meta=None) (id : type_id) (ctx : extraction_ctx) : string = + cassert_opt_meta (id <> TTuple) meta "T"; + ctx_get ~meta:meta (TypeId id) ctx let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) (ctx : extraction_ctx) : string = - ctx_get_type meta (TAdtId id) ctx + ctx_get_type ~meta:(Some meta) (TAdtId id) ctx -let ctx_get_assumed_type (meta : Meta.meta) (id : assumed_ty) (ctx : extraction_ctx) : string = - ctx_get_type meta (TAssumed id) ctx +let ctx_get_assumed_type ?(meta = None) (id : assumed_ty) (ctx : extraction_ctx) : string = + ctx_get_type ~meta:meta (TAssumed id) ctx let ctx_get_trait_constructor (id : trait_decl_id) (ctx : extraction_ctx) : string = let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in - ctx_get meta (TraitDeclConstructorId id) ctx + ctx_get ~meta:(Some meta) (TraitDeclConstructorId id) ctx let ctx_get_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : string = - ctx_get meta TraitSelfClauseId ctx + ctx_get ~meta:(Some meta) TraitSelfClauseId ctx let ctx_get_trait_decl (id : trait_decl_id) (ctx : extraction_ctx) : string = let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in - ctx_get meta (TraitDeclId id) ctx + ctx_get ~meta:(Some meta) (TraitDeclId id) ctx let ctx_get_trait_impl (id : trait_impl_id) (ctx : extraction_ctx) : string = let meta = (TraitImplId.Map.find id ctx.trans_trait_impls).meta in - ctx_get meta (TraitImplId id) ctx + ctx_get ~meta:(Some meta) (TraitImplId id) ctx let ctx_get_trait_item (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in - ctx_get meta (TraitItemId (id, item_name)) ctx + ctx_get ~meta:(Some meta) (TraitItemId (id, item_name)) ctx let ctx_get_trait_const (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = @@ -720,51 +720,51 @@ let ctx_get_trait_type (id : trait_decl_id) (item_name : string) let ctx_get_trait_method (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in - ctx_get meta (TraitMethodId (id, item_name)) ctx + ctx_get ~meta:(Some meta) (TraitMethodId (id, item_name)) ctx let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in - ctx_get meta (TraitParentClauseId (id, clause)) ctx + ctx_get ~meta:(Some meta) (TraitParentClauseId (id, clause)) ctx let ctx_get_trait_item_clause (id : trait_decl_id) (item : string) (clause : trait_clause_id) (ctx : extraction_ctx) : string = let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in - ctx_get meta (TraitItemClauseId (id, item, clause)) ctx + ctx_get ~meta:(Some meta) (TraitItemClauseId (id, item, clause)) ctx let ctx_get_var (meta : Meta.meta) (id : VarId.id) (ctx : extraction_ctx) : string = - ctx_get meta (VarId id) ctx + ctx_get ~meta:(Some meta) (VarId id) ctx let ctx_get_type_var (meta : Meta.meta) (id : TypeVarId.id) (ctx : extraction_ctx) : string = - ctx_get meta (TypeVarId id) ctx + ctx_get ~meta:(Some meta) (TypeVarId id) ctx let ctx_get_const_generic_var (meta : Meta.meta) (id : ConstGenericVarId.id) (ctx : extraction_ctx) : string = - ctx_get meta (ConstGenericVarId id) ctx + ctx_get ~meta:(Some meta) (ConstGenericVarId id) ctx let ctx_get_local_trait_clause (meta : Meta.meta) (id : TraitClauseId.id) (ctx : extraction_ctx) : string = - ctx_get meta (LocalTraitClauseId id) ctx + ctx_get ~meta:(Some meta) (LocalTraitClauseId id) ctx let ctx_get_field (meta : Meta.meta) (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = (* let meta = (TypeDeclId.Map.find type_id ctx.trans_types).meta in TODO : check how to get meta *) - ctx_get meta (FieldId (type_id, field_id)) ctx + ctx_get ~meta:(Some meta) (FieldId (type_id, field_id)) ctx let ctx_get_struct (meta : Meta.meta) (def_id : type_id) (ctx : extraction_ctx) : string = - ctx_get meta (StructId def_id) ctx + ctx_get ~meta:(Some meta) (StructId def_id) ctx let ctx_get_variant (meta : Meta.meta) (def_id : type_id) (variant_id : VariantId.id) (ctx : extraction_ctx) : string = - ctx_get meta (VariantId (def_id, variant_id)) ctx + ctx_get ~meta:(Some meta) (VariantId (def_id, variant_id)) ctx let ctx_get_decreases_proof (meta : Meta.meta) (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get meta (DecreasesProofId (FRegular def_id, loop_id)) ctx + ctx_get ~meta:(Some meta) (DecreasesProofId (FRegular def_id, loop_id)) ctx let ctx_get_termination_measure (meta : Meta.meta) (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get meta (TerminationMeasureId (FRegular def_id, loop_id)) ctx + ctx_get ~meta:(Some meta) (TerminationMeasureId (FRegular def_id, loop_id)) ctx (** Small helper to compute the name of a unary operation *) let unop_name (unop : unop) : string = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 51ed7f5a..0329d968 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -287,7 +287,7 @@ let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt ("val [" ^ String.concat ", " names ^ "] = DefineDiv ‘") else ( - assert (List.length names = 1); + assert (List.length names = 1) (* TODO: Error message, meta todo*); let name = List.hd names in F.pp_print_string fmt ("val " ^ name ^ " = Define ‘")); F.pp_print_cut fmt () @@ -470,7 +470,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) if print_paren then F.pp_print_string fmt "("; (* TODO: for now, only the opaque *functions* are extracted in the opaque module. The opaque *types* are assumed. *) - F.pp_print_string fmt (ctx_get_type meta type_id ctx); + F.pp_print_string fmt (ctx_get_type ~meta:(Some meta) type_id ctx); (* We might need to filter the type arguments, if the type is builtin (for instance, we filter the global allocator type argument for `Vec`). *) @@ -496,7 +496,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) | HOL4 -> let { types; const_generics; trait_refs } = generics in (* Const generics are not supported in HOL4 *) - assert (const_generics = []); + cassert (const_generics = []) meta "Const generics are not supported in HOL4"; let print_tys = match type_id with | TAdtId id -> not (TypeDeclId.Set.mem id no_params_tys) @@ -513,7 +513,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (extract_rec true) types; if print_paren then F.pp_print_string fmt ")"; F.pp_print_space fmt ()); - F.pp_print_string fmt (ctx_get_type meta type_id ctx); + F.pp_print_string fmt (ctx_get_type ~meta:(Some meta) type_id ctx); if trait_refs <> [] then ( F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) @@ -554,7 +554,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt type_name | _ -> (* HOL4 doesn't have 1st class types *) - assert (!backend <> HOL4); + cassert (!backend <> HOL4) meta "TODO: Error message"; extract_trait_ref meta ctx fmt no_params_tys false trait_ref; F.pp_print_string fmt ("." ^ add_brackets type_name)) @@ -606,7 +606,7 @@ and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.form (extract_ty meta ctx fmt no_params_tys true) types); if const_generics <> [] then ( - assert (!backend <> HOL4); + cassert (!backend <> HOL4) meta "TODO: Error message"; F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) (extract_const_generic meta ctx fmt true) @@ -878,7 +878,7 @@ let extract_type_decl_variant (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields in (* Sanity check: HOL4 doesn't support const generics *) - assert (cg_params = [] || !backend <> HOL4); + cassert (cg_params = [] || !backend <> HOL4) meta "TODO: Error message"; (* Print the final type *) if !backend <> HOL4 then ( F.pp_print_space fmt (); @@ -1076,7 +1076,7 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) else ( (* We extract for Coq or Lean, and we have a recursive record, or a record in a group of mutually recursive types: we extract it as an inductive type *) - assert (is_rec && (!backend = Coq || !backend = Lean)); + cassert (is_rec && (!backend = Coq || !backend = Lean)) def.meta "TODO: error message"; (* Small trick: in Lean we use namespaces, meaning we don't need to prefix the constructor name with the name of the type at definition site, i.e., instead of generating `inductive Foo := | MkFoo ...` like in Coq @@ -1130,10 +1130,11 @@ let extract_comment_with_span (ctx : extraction_ctx) (fmt : F.formatter) in extract_comment fmt (sl @ [ span ] @ name) -let extract_trait_clause_type meta (ctx : extraction_ctx) (fmt : F.formatter) +let extract_trait_clause_type (* (meta : Meta.meta) TODO check if right meta*) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = let trait_name = ctx_get_trait_decl clause.trait_id ctx in F.pp_print_string fmt trait_name; + let meta = (TraitDeclId.Map.find clause.trait_id ctx.trans_trait_decls).meta in extract_generic_args meta ctx fmt no_params_tys clause.generics (** Insert a space, if necessary *) @@ -1176,7 +1177,7 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* HOL4 doesn't support const generics *) - assert (cg_params = [] || !backend <> HOL4); + cassert (cg_params = [] || !backend <> HOL4) meta "HOL4 doesn't support const generics"; let left_bracket (implicit : bool) = if implicit && !backend <> FStar then F.pp_print_string fmt "{" else F.pp_print_string fmt "(" @@ -1257,7 +1258,7 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_trait_clause_type meta ctx fmt no_params_tys clause; + extract_trait_clause_type ctx fmt no_params_tys clause; (* ) *) right_bracket as_implicits; if use_arrows then ( @@ -1323,7 +1324,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) (extract_body : bool) : unit = (* Sanity check *) - assert (extract_body || !backend <> HOL4); + cassert (extract_body || !backend <> HOL4) def.meta "TODO: error message"; let is_tuple_struct = TypesUtils.type_decl_from_decl_id_is_tuple_struct ctx.trans_ctx.type_ctx.type_infos def.def_id @@ -1394,7 +1395,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) | None -> F.pp_print_string fmt def_name); (* HOL4 doesn't support const generics, and type definitions in HOL4 don't support trait clauses *) - assert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4); + cassert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4) def.meta "HOL4 doesn't support const generics, and type definitions in HOL4 don't support trait clauses"; (* Print the generic parameters *) extract_generic_params def.meta ctx_body fmt type_decl_group ~use_forall def.generics type_params cg_params trait_clauses; @@ -1463,9 +1464,9 @@ let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (* Retrieve the definition name *) let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Generic parameters are unsupported *) - assert (def.generics.const_generics = []); + cassert (def.generics.const_generics = []) def.meta "Generic parameters are unsupported"; (* Trait clauses on type definitions are unsupported *) - assert (def.generics.trait_clauses = []); + cassert (def.generics.trait_clauses = []) def.meta "Trait clauses on type definitions are unsupported"; (* Types *) (* Count the number of parameters *) let num_params = List.length def.generics.types in @@ -1488,7 +1489,7 @@ let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) (* Retrieve the definition name *) let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Sanity check *) - assert (def.generics = empty_generic_params); + cassert (def.generics = empty_generic_params) def.meta "TODO: error message"; (* Generate the declaration *) F.pp_print_space fmt (); F.pp_print_string fmt ("Type " ^ def_name ^ " = “: unit”"); @@ -1564,7 +1565,7 @@ let extract_coq_arguments_instruction (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = - assert (!backend = Coq); + cassert (!backend = Coq) decl.meta "TODO: error message"; (* Generating the [Arguments] instructions is useful only if there are parameters *) let num_params = List.length decl.generics.types @@ -1610,7 +1611,7 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_type_decl_record_field_projectors (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = - assert (!backend = Coq); + cassert (!backend = Coq) decl.meta "TODO: error message"; match decl.kind with | Opaque | Enum _ -> () | Struct fields -> @@ -1770,7 +1771,7 @@ let extract_type_decl_extra_info (ctx : extraction_ctx) (fmt : F.formatter) extract_type_decl_record_field_projectors ctx fmt kind decl) (** Extract the state type declaration. *) -let extract_state_type (meta : Meta.meta) (fmt : F.formatter) (ctx : extraction_ctx) +let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) (kind : decl_kind) : unit = (* Add a break before *) F.pp_print_break fmt 0 0; @@ -1781,14 +1782,14 @@ let extract_state_type (meta : Meta.meta) (fmt : F.formatter) (ctx : extraction_ * one line *) F.pp_open_hvbox fmt 0; (* Retrieve the name *) - let state_name = ctx_get_assumed_type meta TState ctx in + let state_name = ctx_get_assumed_type TState ctx in (* The syntax for Lean and Coq is almost identical. *) let print_axiom () = let axiom = match !backend with | Coq -> "Axiom" | Lean -> "axiom" - | FStar | HOL4 -> craise meta "Unexpected" + | FStar | HOL4 -> raise (Failure "Unexpected") in F.pp_print_string fmt axiom; F.pp_print_space fmt (); @@ -1802,7 +1803,7 @@ let extract_state_type (meta : Meta.meta) (fmt : F.formatter) (ctx : extraction_ (* The kind should be [Assumed] or [Declared] *) (match kind with | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> - craise meta "Unexpected" + raise (Failure "Unexpected") | Assumed -> ( match !backend with | FStar -> diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 3e887741..6ef4a13b 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -53,8 +53,8 @@ type abs_borrows_loans_maps = { regions. *) module type PrimMatcher = sig - val match_etys : eval_ctx -> eval_ctx -> ety -> ety -> ety - val match_rtys : eval_ctx -> eval_ctx -> rty -> rty -> rty + val match_etys : Meta.meta -> eval_ctx -> eval_ctx -> ety -> ety -> ety + val match_rtys : Meta.meta -> eval_ctx -> eval_ctx -> rty -> rty -> rty (** The input primitive values are not equal *) val match_distinct_literals : @@ -111,6 +111,7 @@ module type PrimMatcher = sig [v]: the result of matching the shared values coming from the two loans *) val match_shared_loans : + Meta.meta -> eval_ctx -> eval_ctx -> ety -> diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 08d18407..0e0a06e3 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -43,8 +43,8 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) match Id0.Map.find_opt id0 !map with | None -> () | Some set -> - assert ( - (not check_not_already_registered) || not (Id1.Set.mem id1 set))); + cassert ( + (not check_not_already_registered) || not (Id1.Set.mem id1 set)) meta "TODO: error message"); (* Update the mapping *) map := Id0.Map.update id0 @@ -53,10 +53,10 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) | None -> Some (Id1.Set.singleton id1) | Some ids -> (* Sanity check *) - assert (not check_singleton_sets); - assert ( + cassert (not check_singleton_sets) meta "TODO: error message"; + cassert ( (not check_not_already_registered) - || not (Id1.Set.mem id1 ids)); + || not (Id1.Set.mem id1 ids)) meta "TODO: error message"; (* Update *) Some (Id1.Set.add id1 ids)) !map @@ -144,14 +144,14 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) TODO: probably don't need to take [match_regions] as input anymore. *) -let rec match_types (match_distinct_types : ty -> ty -> ty) +let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) (match_regions : region -> region -> region) (ty0 : ty) (ty1 : ty) : ty = - let match_rec = match_types match_distinct_types match_regions in + let match_rec = match_types meta match_distinct_types match_regions in match (ty0, ty1) with | TAdt (id0, generics0), TAdt (id1, generics1) -> - assert (id0 = id1); - assert (generics0.const_generics = generics1.const_generics); - assert (generics0.trait_refs = generics1.trait_refs); + cassert (id0 = id1) meta "T"; + cassert (generics0.const_generics = generics1.const_generics) meta "T"; + cassert (generics0.trait_refs = generics1.trait_refs) meta "T"; let id = id0 in let const_generics = generics1.const_generics in let trait_refs = generics1.trait_refs in @@ -168,17 +168,17 @@ let rec match_types (match_distinct_types : ty -> ty -> ty) let generics = { regions; types; const_generics; trait_refs } in TAdt (id, generics) | TVar vid0, TVar vid1 -> - assert (vid0 = vid1); + cassert (vid0 = vid1) meta "T"; let vid = vid0 in TVar vid | TLiteral lty0, TLiteral lty1 -> - assert (lty0 = lty1); + cassert (lty0 = lty1) meta "T"; ty0 | TNever, TNever -> ty0 | TRef (r0, ty0, k0), TRef (r1, ty1, k1) -> let r = match_regions r0 r1 in let ty = match_rec ty0 ty1 in - assert (k0 = k1); + cassert (k0 = k1) meta "T"; let k = k0 in TRef (r, ty, k) | _ -> match_distinct_types ty0 ty1 @@ -187,7 +187,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let rec match_typed_values (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (v0 : typed_value) (v1 : typed_value) : typed_value = let match_rec = match_typed_values meta ctx0 ctx1 in - let ty = M.match_etys ctx0 ctx1 v0.ty v1.ty in + let ty = M.match_etys meta ctx0 ctx1 v0.ty v1.ty in (* Using ValuesUtils.value_has_borrows on purpose here: we want to make explicit the fact that, though we have to pick one of the two contexts (ctx0 here) to call value_has_borrows, @@ -210,8 +210,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct { value; ty = v1.ty } else ( (* For now, we don't merge ADTs which contain borrows *) - assert (not (value_has_borrows v0.value)); - assert (not (value_has_borrows v1.value)); + cassert (not (value_has_borrows v0.value)) meta "ADTs which contain borrows are not merged yet"; + cassert (not (value_has_borrows v1.value)) meta "ADTs which contain borrows are not merged yet"; (* Merge *) M.match_distinct_adts meta ctx0 ctx1 ty av0 av1) | VBottom, VBottom -> v0 @@ -226,10 +226,10 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> let bv = match_rec bv0 bv1 in - assert ( + cassert ( not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos - bv.value)); + bv.value)) meta "T"; let bid, bv = M.match_mut_borrows meta ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv in @@ -252,8 +252,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (lc0, lc1) with | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in - assert (not (value_has_borrows sv.value)); - let ids, sv = M.match_shared_loans ctx0 ctx1 ty ids0 ids1 sv in + cassert (not (value_has_borrows sv.value)) meta "T"; + let ids, sv = M.match_shared_loans meta ctx0 ctx1 ty ids0 ids1 sv in VSharedLoan (ids, sv) | VMutLoan id0, VMutLoan id1 -> let id = M.match_mut_loans ctx0 ctx1 ty id0 id1 in @@ -265,8 +265,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | VSymbolic sv0, VSymbolic sv1 -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - assert (not (value_has_borrows v0.value)); - assert (not (value_has_borrows v1.value)); + cassert (not (value_has_borrows v0.value)) meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; + cassert (not (value_has_borrows v1.value)) meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; (* Match *) let sv = M.match_symbolic_values meta ctx0 ctx1 sv0 sv1 in { v1 with value = VSymbolic sv } @@ -310,7 +310,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let match_rec = match_typed_values meta ctx0 ctx1 in let match_arec = match_typed_avalues meta ctx0 ctx1 in - let ty = M.match_rtys ctx0 ctx1 v0.ty v1.ty in + let ty = M.match_rtys meta ctx0 ctx1 v0.ty v1.ty in match (v0.value, v1.value) with | AAdt av0, AAdt av1 -> if av0.variant_id = av1.variant_id then @@ -373,7 +373,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct log#ldebug (lazy "match_typed_avalues: shared loans"); let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in - assert (not (value_has_borrows sv.value)); + cassert (not (value_has_borrows sv.value)) meta "T"; M.match_ashared_loans meta ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 av1 ty sv av | AMutLoan (id0, av0), AMutLoan (id1, av1) -> @@ -403,14 +403,14 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let push_absl (absl : abs list) : unit = List.iter push_abs absl - let match_etys _ _ ty0 ty1 = - assert (ty0 = ty1); + let match_etys (meta : Meta.meta) _ _ ty0 ty1 = + cassert (ty0 = ty1) meta "T"; ty0 - let match_rtys _ _ ty0 ty1 = + let match_rtys (meta : Meta.meta) _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) - assert (ty0 = ty1); + cassert (ty0 = ty1) meta "The types must be equal - in effect, this forbids to match symbolic values containing borrows"; ty0 let match_distinct_literals (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) @@ -424,7 +424,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct updates *) let check_no_borrows ctx (v : typed_value) = - assert (not (value_has_borrows ctx v.value)) + cassert (not (value_has_borrows ctx v.value)) meta "ADTs should not contain borrows" in List.iter (check_no_borrows ctx0) adt0.field_values; List.iter (check_no_borrows ctx1) adt1.field_values; @@ -559,11 +559,11 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct do so, we won't introduce reborrows like above: the forward loop function will update [v], while the backward loop function will return nothing. *) - assert ( - not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)); + cassert ( + not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) meta "T"; if bv0 = bv1 then ( - assert (bv0 = bv); + cassert (bv0 = bv) meta "T"; (bid0, bv)) else let rid = fresh_region_id () in @@ -571,7 +571,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let kind = RMut in let bv_ty = bv.ty in - assert (ty_no_regions bv_ty); + cassert (ty_no_regions bv_ty) meta "T"; let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in let borrow_av = @@ -624,7 +624,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = let bv_ty = bv.ty in - assert (ty_no_regions bv_ty); + cassert (ty_no_regions bv_ty) meta "T"; let value = ABorrow (AMutBorrow (bid, mk_aignored meta bv_ty)) in { value; ty = borrow_ty } in @@ -654,7 +654,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) (bid2, sv) - let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) + let match_shared_loans (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) (sv : typed_value) : loan_id_set * typed_value = (* Check if the ids are the same - Rem.: we forbid the sets of loans @@ -671,7 +671,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct raise (ValueMatchFailure (LoansInRight extra_ids_right)); (* This should always be true if we get here *) - assert (ids0 = ids1); + cassert (ids0 = ids1) meta "This should always be true if we get here "; let ids = ids0 in (* Return *) @@ -691,13 +691,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let id1 = sv1.sv_id in if id0 = id1 then ( (* Sanity check *) - assert (sv0 = sv1); + cassert (sv0 = sv1) meta "T"; (* Return *) sv0) else ( (* The caller should have checked that the symbolic values don't contain borrows *) - assert (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)); + cassert (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)) meta "The caller should have checked that the symbolic values don't contain borrows"; (* We simply introduce a fresh symbolic value *) mk_fresh_symbolic_value meta sv0.sv_ty) @@ -709,8 +709,14 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct If there are loans in the regular value, raise an exception. *) let type_infos = ctx0.type_ctx.type_infos in - assert (not (ty_has_borrows type_infos sv.sv_ty)); - assert (not (ValuesUtils.value_has_borrows type_infos v.value)); + cassert (not (ty_has_borrows type_infos sv.sv_ty)) meta "Check that: + - there are no borrows in the symbolic value + - there are no borrows in the \"regular\" value + If there are loans in the regular value, raise an exception."; + cassert (not (ValuesUtils.value_has_borrows type_infos v.value)) meta "Check that: + - there are no borrows in the symbolic value + - there are no borrows in the \"regular\" value + If there are loans in the regular value, raise an exception."; let value_is_left = not left in (match InterpreterBorrowsCore.get_first_loan_in_value v with | None -> () @@ -804,14 +810,14 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (** Small utility *) let push_moved_value (v : typed_value) : unit = S.nvalues := v :: !S.nvalues - let match_etys _ _ ty0 ty1 = - assert (ty0 = ty1); + let match_etys (meta : Meta.meta) _ _ ty0 ty1 = + cassert (ty0 = ty1) meta "T"; ty0 - let match_rtys _ _ ty0 ty1 = + let match_rtys (meta : Meta.meta) _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) - assert (ty0 = ty1); + cassert (ty0 = ty1) meta "The types must be equal - in effect, this forbids to match symbolic values containing borrows"; ty0 let match_distinct_literals (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) @@ -835,7 +841,7 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (* There can't be bottoms in borrowed values *) (bid1, bv1) - let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) + let match_shared_loans (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (_ : loan_id_set) (ids1 : loan_id_set) (sv : typed_value) : loan_id_set * typed_value = (* There can't be bottoms in shared loans *) @@ -983,10 +989,10 @@ struct let match_aids = GetSetAid.match_es "match_aids: " S.aid_map (** *) - let match_etys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = + let match_etys (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = if ty0 <> ty1 then raise (Distinct "match_etys") else ty0 - let match_rtys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = + let match_rtys (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = let match_distinct_types _ _ = raise (Distinct "match_rtys") in let match_regions r0 r1 = match (r0, r1) with @@ -996,7 +1002,7 @@ struct RFVar rid | _ -> raise (Distinct "match_rtys") in - match_types match_distinct_types match_regions ty0 ty1 + match_types meta match_distinct_types match_regions ty0 ty1 let match_distinct_literals (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = @@ -1042,7 +1048,7 @@ struct let bid = match_borrow_id bid0 bid1 in (bid, bv) - let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) + let match_shared_loans (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) (sv : typed_value) : loan_id_set * typed_value = let ids = match_loan_ids ids0 ids1 in @@ -1052,7 +1058,7 @@ struct (bid1 : loan_id) : loan_id = match_loan_id bid0 bid1 - let match_symbolic_values (_ : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_symbolic_values (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -1071,12 +1077,12 @@ struct let sv_id = GetSetSid.match_e "match_symbolic_values: ids: " S.sid_map id0 id1 in - let sv_ty = match_rtys ctx0 ctx1 sv0.sv_ty sv1.sv_ty in + let sv_ty = match_rtys meta ctx0 ctx1 sv0.sv_ty sv1.sv_ty in let sv = { sv_id; sv_ty } in sv else ( (* Check: fixed values are fixed *) - assert (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)); + cassert (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)) meta "Fixed values should be fixed"; (* Update the symbolic value mapping *) let sv1 = mk_typed_value_from_symbolic_value sv1 in @@ -1093,10 +1099,10 @@ struct (sv : symbolic_value) (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( - assert left; + cassert left meta "T"; let id = sv.sv_id in (* Check: fixed values are fixed *) - assert (not (SymbolicValueId.InjSubst.mem id !S.sid_map)); + cassert (not (SymbolicValueId.InjSubst.mem id !S.sid_map)) meta "Fixed values should be fixed"; (* Update the binding for the target symbolic value *) S.sid_to_value_map := SymbolicValueId.Map.add_strict id v !S.sid_to_value_map; @@ -1314,17 +1320,17 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) be the same and their values equal (and the borrows/loans/symbolic *) if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Fixed values: the values must be equal *) - assert (b0 = b1); - assert (v0 = v1); + cassert (b0 = b1) meta "The fixed values should be equal"; + cassert (v0 = v1) meta "The fixed values should be equal"; (* The ids present in the left value must be fixed *) let ids, _ = compute_typed_value_ids v0 in - assert ((not S.check_equiv) || ids_are_fixed ids)); + cassert ((not S.check_equiv) || ids_are_fixed ids)) meta "T"; (* We still match the values - allows to compute mappings (which are the identity actually) *) let _ = M.match_typed_values meta ctx0 ctx1 v0 v1 in match_envs env0' env1' | EBinding (BVar b0, v0) :: env0', EBinding (BVar b1, v1) :: env1' -> - assert (b0 = b1); + cassert (b0 = b1) meta "T"; (* Match the values *) let _ = M.match_typed_values meta ctx0 ctx1 v0 v1 in (* Continue *) @@ -1335,10 +1341,10 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( log#ldebug (lazy "match_ctxs: match_envs: matching abs: fixed abs"); (* Still in the prefix: the abstractions must be the same *) - assert (abs0 = abs1); + cassert (abs0 = abs1) meta "The abstractions should be the same"; (* Their ids must be fixed *) let ids, _ = compute_abs_ids abs0 in - assert ((not S.check_equiv) || ids_are_fixed ids); + cassert ((not S.check_equiv) || ids_are_fixed ids) meta "The ids should be fixed"; (* Continue *) match_envs env0' env1') else ( @@ -1442,11 +1448,11 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id (fun (var0, var1) -> match (var0, var1) with | EBinding (BDummy b0, v0), EBinding (BDummy b1, v1) -> - assert (b0 = b1); + cassert (b0 = b1) meta "T"; let _ = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in () | EBinding (BVar b0, v0), EBinding (BVar b1, v1) -> - assert (b0 = b1); + cassert (b0 = b1) meta "T"; let _ = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in () | _ -> craise meta "Unexpected") @@ -1479,11 +1485,11 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id (fun (var0, var1) -> match (var0, var1) with | EBinding (BDummy b0, v0), EBinding ((BDummy b1 as var1), v1) -> - assert (b0 = b1); + cassert (b0 = b1) meta "T"; let v = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in (var1, v) | EBinding (BVar b0, v0), EBinding ((BVar b1 as var1), v1) -> - assert (b0 = b1); + cassert (b0 = b1) meta "T"; let v = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in (var1, v) | _ -> craise meta "Unexpected") @@ -1584,7 +1590,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) let filt_src_env, new_absl, new_dummyl = ctx_split_fixed_new meta fixed_ids src_ctx in - assert (new_dummyl = []); + cassert (new_dummyl = []) meta "T"; let filt_tgt_ctx = { tgt_ctx with env = filt_tgt_env } in let filt_src_ctx = { src_ctx with env = filt_src_env } in @@ -1720,7 +1726,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) abstractions and in the *variable bindings* once we allow symbolic values containing borrows to not be eagerly expanded. *) - assert Config.greedy_expand_symbolics_with_borrows; + cassert Config.greedy_expand_symbolics_with_borrows meta "T"; (* Update the borrows and loans in the abstractions of the target context. @@ -1789,8 +1795,8 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) (* No mapping: this means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) and because of this, it should actually be mapped to itself *) - assert ( - BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id); + cassert ( + BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id) meta "The borrow should mapped to itself: no mapping means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) "; id | Some id -> id @@ -1802,8 +1808,8 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) method! visit_abs env abs = match abs.kind with | Loop (loop_id', rg_id, kind) -> - assert (loop_id' = loop_id); - assert (kind = LoopSynthInput); + cassert (loop_id' = loop_id) meta "T"; + cassert (kind = LoopSynthInput) meta "T"; let can_end = false in let kind : abs_kind = Loop (loop_id, rg_id, LoopCall) in let abs = { abs with kind; can_end } in diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index c6db7f2e..c7141064 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -354,7 +354,7 @@ let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_i should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) - let def = ctx_lookup_type_decl ctx def_id in (*TODO: check if can be moved before assert ?*) + let def = ctx_lookup_type_decl ctx def_id in cassert (List.length generics.regions = List.length def.generics.regions) meta "TODO: Error message"; (* Compute the field types *) let field_types = diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index e71b7b68..b71daac5 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1551,7 +1551,7 @@ and eval_function_body (meta : Meta.meta) (config : config) (body : statement) : * checking the invariants *) let cc = greedy_expand_symbolic_values body.meta config in (* Sanity check *) - let cc = comp_check_ctx cc (Invariants.check_invariants meta) in + let cc = comp_check_ctx cc (Invariants.check_invariants meta) in (* Check if right meta *) (* Continue *) cc (cf res) in diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 618a8afc..3008e1bd 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -294,7 +294,7 @@ let mplace_to_string (env : fmt_env) (p : mplace) : string = let name = name ^ "^" ^ E.VarId.to_string p.var_id ^ "llbc" in mprojection_to_string env name p.projection -let adt_variant_to_string (meta : Meta.meta) (env : fmt_env) (adt_id : type_id) +let adt_variant_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) (variant_id : VariantId.id option) : string = match adt_id with | TTuple -> "Tuple" @@ -308,29 +308,29 @@ let adt_variant_to_string (meta : Meta.meta) (env : fmt_env) (adt_id : type_id) match aty with | TState | TArray | TSlice | TStr | TRawPtr _ -> (* Those types are opaque: we can't get there *) - craise meta "Unreachable" + craise_opt_meta meta "Unreachable" | TResult -> let variant_id = Option.get variant_id in if variant_id = result_return_id then "@Result::Return" else if variant_id = result_fail_id then "@Result::Fail" else - craise meta "Unreachable: improper variant id for result type" + craise_opt_meta meta "Unreachable: improper variant id for result type" | TError -> let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" - else craise meta "Unreachable: improper variant id for error type" + else craise_opt_meta meta "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then "@Fuel::Zero" else if variant_id = fuel_succ_id then "@Fuel::Succ" - else craise meta "Unreachable: improper variant id for fuel type") + else craise_opt_meta meta "Unreachable: improper variant id for fuel type") -let adt_field_to_string (meta : Meta.meta) (env : fmt_env) (adt_id : type_id) +let adt_field_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) (field_id : FieldId.id) : string = match adt_id with | TTuple -> - craise meta "Unreachable" + craise_opt_meta meta "Unreachable" (* Tuples don't use the opaque field id for the field indices, but [int] *) | TAdtId def_id -> ( (* "Regular" ADT *) @@ -343,10 +343,10 @@ let adt_field_to_string (meta : Meta.meta) (env : fmt_env) (adt_id : type_id) match aty with | TState | TFuel | TArray | TSlice | TStr -> (* Opaque types: we can't get there *) - craise meta "Unreachable" + craise_opt_meta meta "Unreachable" | TResult | TError | TRawPtr _ -> (* Enumerations: we can't get there *) - craise meta "Unreachable") + craise_opt_meta meta "Unreachable") (** TODO: we don't need a general function anymore (it is now only used for patterns) @@ -611,13 +611,13 @@ and app_to_string (meta : Meta.meta) (env : fmt_env) (inside : bool) (indent : s (global_decl_id_to_string env global_id, generics) | AdtCons adt_cons_id -> let variant_s = - adt_variant_to_string meta env adt_cons_id.adt_id + adt_variant_to_string ~meta:(Some meta) env adt_cons_id.adt_id adt_cons_id.variant_id in (ConstStrings.constructor_prefix ^ variant_s, []) | Proj { adt_id; field_id } -> - let adt_s = adt_variant_to_string meta env adt_id None in - let field_s = adt_field_to_string meta env adt_id field_id in + let adt_s = adt_variant_to_string ~meta:(Some meta) env adt_id None in + let field_s = adt_field_to_string ~meta:(Some meta) env adt_id field_id in (* Adopting an F*-like syntax *) (ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s, []) | TraitConst (trait_ref, const_name) -> diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 6e3a537e..63605b9c 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -878,7 +878,7 @@ let mk_fuel_input_as_list (ctx : bs_ctx) (info : fun_effect_info) : if function_uses_fuel info then [ mk_fuel_texpression ctx.fuel ] else [] (** Small utility. *) -let compute_raw_fun_effect_info (* (meta : Meta.meta) *) (fun_infos : fun_info A.FunDeclId.Map.t) +let compute_raw_fun_effect_info (meta : Meta.meta) (fun_infos : fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with @@ -896,7 +896,7 @@ let compute_raw_fun_effect_info (* (meta : Meta.meta) *) (fun_infos : fun_info A is_rec = info.is_rec || Option.is_some lid; } | FunId (FAssumed aid) -> - assert (lid = None) (* meta "TODO: error message" *); + cassert (lid = None) meta "TODO: error message"; { can_fail = Assumed.assumed_fun_can_fail aid; stateful_group = false; @@ -921,7 +921,7 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) in { info with is_rec = info.is_rec || Option.is_some lid } | FunId (FAssumed _) -> - compute_raw_fun_effect_info (* ctx.fun_decl.meta *) ctx.fun_ctx.fun_infos fun_id lid gid) + compute_raw_fun_effect_info ctx.fun_decl.meta ctx.fun_ctx.fun_infos fun_id lid gid) | Some lid -> ( (* This is necessarily for the current function *) match fun_id with @@ -981,7 +981,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) (* Is the forward function stateful, and can it fail? *) let fwd_effect_info = - compute_raw_fun_effect_info fun_infos fun_id None None + compute_raw_fun_effect_info meta fun_infos fun_id None None in (* Compute the forward inputs *) let fwd_fuel = mk_fuel_input_ty_as_list fwd_effect_info in @@ -1099,7 +1099,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) RegionGroupId.id * back_sg_info = let gid = rg.id in let back_effect_info = - compute_raw_fun_effect_info fun_infos fun_id None (Some gid) + compute_raw_fun_effect_info meta fun_infos fun_id None (Some gid) in let inputs_no_state = translate_back_inputs_for_gid gid in let inputs_no_state = diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 2ee1324b..11b179db 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -352,7 +352,7 @@ let export_type (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) [is_rec]: [true] if the types are recursive. Necessarily [true] if there is > 1 type to extract. *) -let export_types_group (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) +let export_types_group (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (is_rec : bool) (ids : Pure.TypeDeclId.id list) : unit = assert (ids <> []) (* meta "TODO: Error message" *); let export_type = export_type fmt config ctx in @@ -493,7 +493,7 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) Rem.: this function doesn't check [config.extract_fun_decls]: it should have been checked by the caller. *) -let export_functions_group_scc (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) +let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (is_rec : bool) (decls : Pure.fun_decl list) : unit = (* Utility to check a function has a decrease clause *) let has_decreases_clause (def : Pure.fun_decl) : bool = @@ -504,7 +504,7 @@ let export_functions_group_scc (meta : Meta.meta) (fmt : Format.formatter) (conf (* Extract the function declarations *) (* Check if the functions are mutually recursive *) let is_mut_rec = List.length decls > 1 in - cassert ((not is_mut_rec) || is_rec) meta "TODO: Error message"; + assert ((not is_mut_rec) || is_rec); let decls_length = List.length decls in (* We open and close the declaration group with [{start, end}_fun_decl_group]. @@ -568,7 +568,7 @@ let export_functions_group_scc (meta : Meta.meta) (fmt : Format.formatter) (conf In case of (non-mutually) recursive functions, we use a simple procedure to check if the forward and backward functions are mutually recursive. *) -let export_functions_group (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) +let export_functions_group (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (pure_ls : pure_fun_translation list) : unit = (* Check if the definition are builtin - if yes they must be ignored. Note that if one definition in the group is builtin, then all the @@ -584,7 +584,7 @@ let export_functions_group (meta : Meta.meta) (fmt : Format.formatter) (config : if List.exists (fun b -> b) builtin then (* Sanity check *) - cassert (List.for_all (fun b -> b) builtin) meta "TODO: Error message" + assert (List.for_all (fun b -> b) builtin) else (* Utility to check a function has a decrease clause *) let has_decreases_clause (def : Pure.fun_decl) : bool = @@ -616,11 +616,11 @@ let export_functions_group (meta : Meta.meta) (fmt : Format.formatter) (config : | FStar -> Extract.extract_template_fstar_decreases_clause ctx fmt decl | Coq -> - craise - meta "Coq doesn't have decreases/termination clauses" + raise + (Failure "Coq doesn't have decreases/termination clauses") | HOL4 -> - craise - meta "HOL4 doesn't have decreases/termination clauses" + raise + (Failure "HOL4 doesn't have decreases/termination clauses") in extract_decrease f.f; List.iter extract_decrease f.loops) @@ -639,7 +639,7 @@ let export_functions_group (meta : Meta.meta) (fmt : Format.formatter) (config : (* Extract the subgroups *) let export_subgroup (is_rec : bool) (decls : Pure.fun_decl list) : unit = - export_functions_group_scc meta fmt config ctx is_rec decls + export_functions_group_scc fmt config ctx is_rec decls in List.iter (fun (is_rec, decls) -> export_subgroup is_rec decls) subgroups); @@ -658,7 +658,7 @@ let export_trait_decl (fmt : Format.formatter) (_config : gen_config) let open ExtractBuiltin in if match_name_find_opt ctx.trans_ctx trait_decl.llbc_name - (builtin_trait_decls_map trait_decl.meta ()) + (builtin_trait_decls_map ()) = None then ( let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in @@ -694,16 +694,16 @@ let export_trait_impl (fmt : Format.formatter) (_config : gen_config) split the definitions between different files (or not), we can control what is precisely extracted. *) -let extract_definitions (meta : Meta.meta) (fmt : Format.formatter) (config : gen_config) +let extract_definitions (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) : unit = (* Export the definition groups to the file, in the proper order. - [extract_decl]: extract the type declaration (if not filtered) - [extract_extra_info]: extra the extra type information (e.g., the [Arguments] information in Coq). *) - let export_functions_group = export_functions_group meta fmt config ctx in + let export_functions_group = export_functions_group fmt config ctx in let export_global = export_global fmt config ctx in - let export_types_group = export_types_group meta fmt config ctx in + let export_types_group = export_types_group fmt config ctx in let export_trait_decl_group id = export_trait_decl fmt config ctx id true false in @@ -716,7 +716,7 @@ let extract_definitions (meta : Meta.meta) (fmt : Format.formatter) (config : ge let kind = if config.interface then ExtractBase.Declared else ExtractBase.Assumed in - Extract.extract_state_type meta fmt ctx kind + Extract.extract_state_type fmt ctx kind in let export_decl_group (dg : declaration_group) : unit = @@ -785,7 +785,7 @@ type extract_file_info = { custom_includes : string list; } -let extract_file (meta : Meta.meta) (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) +let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) : unit = (* Open the file and create the formatter *) let out = open_out fi.filename in @@ -885,7 +885,7 @@ let extract_file (meta : Meta.meta) (config : gen_config) (ctx : gen_ctx) (fi : Format.pp_open_vbox fmt 0; (* Extract the definitions *) - extract_definitions meta fmt config ctx; + extract_definitions fmt config ctx; (* Close the box and end the formatting *) Format.pp_close_box fmt (); @@ -1080,7 +1080,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : let ( ^^ ) = Filename.concat in if !Config.split_files then mkdir_if (dest_dir ^^ crate_name); if needs_clauses_module then ( - assert !Config.split_files (* meta "TODO: Error message META?" *); + assert !Config.split_files; mkdir_if (dest_dir ^^ crate_name ^^ "Clauses"))); (* Copy the "Primitives" file, if necessary *) @@ -1230,7 +1230,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = []; } in - extract_file meta opaque_config ctx file_info; + extract_file opaque_config ctx file_info; (* Return the additional dependencies *) [ opaque_imported_module ]) else [] @@ -1271,7 +1271,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = opaque_types_module; } in - extract_file meta types_config ctx file_info; + extract_file types_config ctx file_info; (* Extract the template clauses *) (if needs_clauses_module && !Config.extract_template_decreases_clauses then @@ -1300,7 +1300,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = []; } in - extract_file meta template_clauses_config ctx file_info); + extract_file template_clauses_config ctx file_info); (* Extract the opaque fun declarations, if needed *) let opaque_funs_module = @@ -1356,7 +1356,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = [ types_module ]; } in - extract_file meta opaque_config ctx file_info; + extract_file opaque_config ctx file_info; (* Return the additional dependencies *) [ opaque_imported_module ]) else [] @@ -1397,7 +1397,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : [ types_module ] @ opaque_funs_module @ clauses_module; } in - extract_file meta fun_config ctx file_info) + extract_file fun_config ctx file_info) else let gen_config = { @@ -1430,7 +1430,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : custom_includes = []; } in - extract_file meta gen_config ctx file_info); + extract_file gen_config ctx file_info); (* Generate the build file *) match !Config.backend with -- cgit v1.2.3 From 9b1a0d82c19375619904efe7e18e064701fb947b Mon Sep 17 00:00:00 2001 From: Escherichia Date: Mon, 25 Mar 2024 10:16:15 +0100 Subject: Replaced some unclear TODOs error message placeholder by clearer TODOs, they were forgotten before last push --- compiler/ExtractBase.ml | 4 +-- compiler/InterpreterBorrowsCore.ml | 2 +- compiler/InterpreterLoopsJoinCtxs.ml | 12 ++++---- compiler/InterpreterLoopsMatchCtxs.ml | 54 +++++++++++++++++------------------ 4 files changed, 36 insertions(+), 36 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 18729af4..71717b57 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -679,7 +679,7 @@ let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) (lp : LoopId ctx_get_function meta (FromLlbc (FunId (FRegular id), lp)) ctx let ctx_get_type ?(meta=None) (id : type_id) (ctx : extraction_ctx) : string = - cassert_opt_meta (id <> TTuple) meta "T"; + cassert_opt_meta (id <> TTuple) meta "TODO: error message"; ctx_get ~meta:meta (TypeId id) ctx let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) (ctx : extraction_ctx) : string = @@ -1641,7 +1641,7 @@ let ctx_compute_var_basename (meta : Meta.meta) (ctx : extraction_ctx) (basename let cl = to_snake_case name in let cl = String.split_on_char '_' cl in let cl = List.filter (fun s -> String.length s > 0) cl in - cassert (List.length cl > 0) meta "T"; + cassert (List.length cl > 0) meta "TODO: error message"; let cl = List.map (fun s -> s.[0]) cl in StringUtils.string_of_chars cl in diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 6691fdcd..a9a98b5c 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -558,7 +558,7 @@ let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) * returning we check that we updated at least once. *) let r = ref false in let update () : avalue = - cassert (not !r) meta ""; + cassert (not !r) meta "TODO: error message"; r := true; nv in diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index ef4807e4..b8d5094b 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -326,8 +326,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id let _ = let _, ty0, _ = ty_as_ref ty0 in let _, ty1, _ = ty_as_ref ty1 in - cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) meta ""; - cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) meta "" + cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) meta "TODO: error message"; + cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) meta "TODO: error message" in (* Same remarks as for [merge_amut_borrows] *) @@ -356,8 +356,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id This time we need to also merge the shared values. We rely on the join matcher [JM] to do so. *) - cassert (not (value_has_loans_or_borrows ctx sv0.value)) meta ""; - cassert (not (value_has_loans_or_borrows ctx sv1.value)) meta ""; + cassert (not (value_has_loans_or_borrows ctx sv0.value)) meta "TODO: error message"; + cassert (not (value_has_loans_or_borrows ctx sv1.value)) meta "TODO: error message"; let ty = ty0 in let child = child0 in let sv = M.match_typed_values meta ctx ctx sv0 sv1 in @@ -425,9 +425,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (* Variables are necessarily in the prefix *) craise meta "Unreachable" | EBinding (BDummy did, _) -> - cassert (not (DummyVarId.Set.mem did fixed_ids.dids)) meta "" + cassert (not (DummyVarId.Set.mem did fixed_ids.dids)) meta "TODO: error message" | EAbs abs -> - cassert (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) meta "" + cassert (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) meta "TODO: error message" | EFrame -> (* This should have been eliminated *) craise meta "Unreachable" diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 0e0a06e3..033e51c1 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -149,9 +149,9 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) let match_rec = match_types meta match_distinct_types match_regions in match (ty0, ty1) with | TAdt (id0, generics0), TAdt (id1, generics1) -> - cassert (id0 = id1) meta "T"; - cassert (generics0.const_generics = generics1.const_generics) meta "T"; - cassert (generics0.trait_refs = generics1.trait_refs) meta "T"; + cassert (id0 = id1) meta "TODO: error message"; + cassert (generics0.const_generics = generics1.const_generics) meta "TODO: error message"; + cassert (generics0.trait_refs = generics1.trait_refs) meta "TODO: error message"; let id = id0 in let const_generics = generics1.const_generics in let trait_refs = generics1.trait_refs in @@ -168,17 +168,17 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) let generics = { regions; types; const_generics; trait_refs } in TAdt (id, generics) | TVar vid0, TVar vid1 -> - cassert (vid0 = vid1) meta "T"; + cassert (vid0 = vid1) meta "TODO: error message"; let vid = vid0 in TVar vid | TLiteral lty0, TLiteral lty1 -> - cassert (lty0 = lty1) meta "T"; + cassert (lty0 = lty1) meta "TODO: error message"; ty0 | TNever, TNever -> ty0 | TRef (r0, ty0, k0), TRef (r1, ty1, k1) -> let r = match_regions r0 r1 in let ty = match_rec ty0 ty1 in - cassert (k0 = k1) meta "T"; + cassert (k0 = k1) meta "TODO: error message"; let k = k0 in TRef (r, ty, k) | _ -> match_distinct_types ty0 ty1 @@ -229,7 +229,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct cassert ( not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos - bv.value)) meta "T"; + bv.value)) meta "TODO: error message"; let bid, bv = M.match_mut_borrows meta ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv in @@ -252,7 +252,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (lc0, lc1) with | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in - cassert (not (value_has_borrows sv.value)) meta "T"; + cassert (not (value_has_borrows sv.value)) meta "TODO: error message"; let ids, sv = M.match_shared_loans meta ctx0 ctx1 ty ids0 ids1 sv in VSharedLoan (ids, sv) | VMutLoan id0, VMutLoan id1 -> @@ -373,7 +373,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct log#ldebug (lazy "match_typed_avalues: shared loans"); let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in - cassert (not (value_has_borrows sv.value)) meta "T"; + cassert (not (value_has_borrows sv.value)) meta "TODO: error message"; M.match_ashared_loans meta ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 av1 ty sv av | AMutLoan (id0, av0), AMutLoan (id1, av1) -> @@ -404,7 +404,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let push_absl (absl : abs list) : unit = List.iter push_abs absl let match_etys (meta : Meta.meta) _ _ ty0 ty1 = - cassert (ty0 = ty1) meta "T"; + cassert (ty0 = ty1) meta "TODO: error message"; ty0 let match_rtys (meta : Meta.meta) _ _ ty0 ty1 = @@ -560,10 +560,10 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct will update [v], while the backward loop function will return nothing. *) cassert ( - not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) meta "T"; + not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) meta "TODO: error message"; if bv0 = bv1 then ( - cassert (bv0 = bv) meta "T"; + cassert (bv0 = bv) meta "TODO: error message"; (bid0, bv)) else let rid = fresh_region_id () in @@ -571,7 +571,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let kind = RMut in let bv_ty = bv.ty in - cassert (ty_no_regions bv_ty) meta "T"; + cassert (ty_no_regions bv_ty) meta "TODO: error message"; let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in let borrow_av = @@ -624,7 +624,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = let bv_ty = bv.ty in - cassert (ty_no_regions bv_ty) meta "T"; + cassert (ty_no_regions bv_ty) meta "TODO: error message"; let value = ABorrow (AMutBorrow (bid, mk_aignored meta bv_ty)) in { value; ty = borrow_ty } in @@ -691,7 +691,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let id1 = sv1.sv_id in if id0 = id1 then ( (* Sanity check *) - cassert (sv0 = sv1) meta "T"; + cassert (sv0 = sv1) meta "TODO: error message"; (* Return *) sv0) else ( @@ -811,7 +811,7 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct let push_moved_value (v : typed_value) : unit = S.nvalues := v :: !S.nvalues let match_etys (meta : Meta.meta) _ _ ty0 ty1 = - cassert (ty0 = ty1) meta "T"; + cassert (ty0 = ty1) meta "TODO: error message"; ty0 let match_rtys (meta : Meta.meta) _ _ ty0 ty1 = @@ -1099,7 +1099,7 @@ struct (sv : symbolic_value) (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( - cassert left meta "T"; + cassert left meta "TODO: error message"; let id = sv.sv_id in (* Check: fixed values are fixed *) cassert (not (SymbolicValueId.InjSubst.mem id !S.sid_map)) meta "Fixed values should be fixed"; @@ -1324,13 +1324,13 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) cassert (v0 = v1) meta "The fixed values should be equal"; (* The ids present in the left value must be fixed *) let ids, _ = compute_typed_value_ids v0 in - cassert ((not S.check_equiv) || ids_are_fixed ids)) meta "T"; + cassert ((not S.check_equiv) || ids_are_fixed ids)) meta "TODO: error message"; (* We still match the values - allows to compute mappings (which are the identity actually) *) let _ = M.match_typed_values meta ctx0 ctx1 v0 v1 in match_envs env0' env1' | EBinding (BVar b0, v0) :: env0', EBinding (BVar b1, v1) :: env1' -> - cassert (b0 = b1) meta "T"; + cassert (b0 = b1) meta "TODO: error message"; (* Match the values *) let _ = M.match_typed_values meta ctx0 ctx1 v0 v1 in (* Continue *) @@ -1448,11 +1448,11 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id (fun (var0, var1) -> match (var0, var1) with | EBinding (BDummy b0, v0), EBinding (BDummy b1, v1) -> - cassert (b0 = b1) meta "T"; + cassert (b0 = b1) meta "TODO: error message"; let _ = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in () | EBinding (BVar b0, v0), EBinding (BVar b1, v1) -> - cassert (b0 = b1) meta "T"; + cassert (b0 = b1) meta "TODO: error message"; let _ = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in () | _ -> craise meta "Unexpected") @@ -1485,11 +1485,11 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id (fun (var0, var1) -> match (var0, var1) with | EBinding (BDummy b0, v0), EBinding ((BDummy b1 as var1), v1) -> - cassert (b0 = b1) meta "T"; + cassert (b0 = b1) meta "TODO: error message"; let v = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in (var1, v) | EBinding (BVar b0, v0), EBinding ((BVar b1 as var1), v1) -> - cassert (b0 = b1) meta "T"; + cassert (b0 = b1) meta "TODO: error message"; let v = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in (var1, v) | _ -> craise meta "Unexpected") @@ -1590,7 +1590,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) let filt_src_env, new_absl, new_dummyl = ctx_split_fixed_new meta fixed_ids src_ctx in - cassert (new_dummyl = []) meta "T"; + cassert (new_dummyl = []) meta "TODO: error message"; let filt_tgt_ctx = { tgt_ctx with env = filt_tgt_env } in let filt_src_ctx = { src_ctx with env = filt_src_env } in @@ -1726,7 +1726,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) abstractions and in the *variable bindings* once we allow symbolic values containing borrows to not be eagerly expanded. *) - cassert Config.greedy_expand_symbolics_with_borrows meta "T"; + cassert Config.greedy_expand_symbolics_with_borrows meta "TODO: error message"; (* Update the borrows and loans in the abstractions of the target context. @@ -1808,8 +1808,8 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) method! visit_abs env abs = match abs.kind with | Loop (loop_id', rg_id, kind) -> - cassert (loop_id' = loop_id) meta "T"; - cassert (kind = LoopSynthInput) meta "T"; + cassert (loop_id' = loop_id) meta "TODO: error message"; + cassert (kind = LoopSynthInput) meta "TODO: error message"; let can_end = false in let kind : abs_kind = Loop (loop_id, rg_id, LoopCall) in let abs = { abs with kind; can_end } in -- cgit v1.2.3 From d6ea35868e30bbc7542bfa09bb04d5b6cbe93b22 Mon Sep 17 00:00:00 2001 From: Escherichia Date: Mon, 25 Mar 2024 12:06:05 +0100 Subject: Inverted meta and config argument orders (from meta -> config to config -> meta) --- compiler/Interpreter.ml | 16 ++-- compiler/InterpreterBorrows.ml | 132 +++++++++++++-------------- compiler/InterpreterBorrows.mli | 18 ++-- compiler/InterpreterExpansion.ml | 54 +++++------ compiler/InterpreterExpansion.mli | 16 ++-- compiler/InterpreterExpressions.ml | 98 ++++++++++---------- compiler/InterpreterExpressions.mli | 10 +-- compiler/InterpreterLoops.ml | 6 +- compiler/InterpreterLoopsFixedPoint.ml | 10 +-- compiler/InterpreterLoopsFixedPoint.mli | 4 +- compiler/InterpreterLoopsJoinCtxs.ml | 6 +- compiler/InterpreterLoopsJoinCtxs.mli | 2 +- compiler/InterpreterLoopsMatchCtxs.ml | 8 +- compiler/InterpreterLoopsMatchCtxs.mli | 2 +- compiler/InterpreterPaths.ml | 46 +++++----- compiler/InterpreterPaths.mli | 10 +-- compiler/InterpreterProjectors.ml | 6 +- compiler/InterpreterProjectors.mli | 4 +- compiler/InterpreterStatements.ml | 154 ++++++++++++++++---------------- compiler/InterpreterStatements.mli | 4 +- 20 files changed, 303 insertions(+), 303 deletions(-) (limited to 'compiler') diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index a9ca415e..6e2c15d7 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -286,7 +286,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) let pop_return_value = is_regular_return in - let cf_pop_frame = pop_frame fdef.meta config pop_return_value in + let cf_pop_frame = pop_frame config fdef.meta pop_return_value in (* We need to find the parents regions/abstractions of the region we * will end - this will allow us to, first, mark the other return @@ -314,7 +314,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : eval_ctx * typed_avalue list = let ctx, avalue = - apply_proj_borrows_on_input_value fdef.meta config ctx abs.regions + apply_proj_borrows_on_input_value config fdef.meta ctx abs.regions abs.ancestors_regions ret_value ret_rty in (ctx, [ avalue ]) @@ -447,7 +447,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) let target_abs_ids = List.append parent_input_abs_ids current_abs_id in let cf_end_target_abs cf = List.fold_left - (fun cf id -> end_abstraction fdef.meta config id cf) + (fun cf id -> end_abstraction config fdef.meta id cf) cf target_abs_ids in (* Generate the Return node *) @@ -513,7 +513,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) let fwd_e = (* Pop the frame and retrieve the returned value at the same time*) let pop_return_value = true in - let cf_pop = pop_frame fdef.meta config pop_return_value in + let cf_pop = pop_frame config fdef.meta pop_return_value in (* Generate the Return node *) let cf_return ret_value : m_fun = fun ctx -> Some (SA.Return (ctx, ret_value)) @@ -563,7 +563,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) (* Pop the frame - there is no returned value to pop: in the translation we will simply call the loop function *) let pop_return_value = false in - let cf_pop = pop_frame fdef.meta config pop_return_value in + let cf_pop = pop_frame config fdef.meta pop_return_value in (* Generate the Return node *) let cf_return _ret_value : m_fun = fun _ctx -> Some (SA.ReturnWithLoop (loop_id, inside_loop)) @@ -603,7 +603,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) (* Evaluate the function *) let symbolic = - eval_function_body fdef.meta config (Option.get fdef.body).body cf_finish ctx + eval_function_body config fdef.meta (Option.get fdef.body).body cf_finish ctx in (* Return *) @@ -644,7 +644,7 @@ module Test = struct | Return -> (* Ok: drop the local variables and finish *) let pop_return_value = true in - pop_frame fdef.meta config pop_return_value (fun _ _ -> None) ctx + pop_frame config fdef.meta pop_return_value (fun _ _ -> None) ctx | _ -> craise fdef.meta @@ -655,7 +655,7 @@ module Test = struct in (* Evaluate the function *) - let _ = eval_function_body body.meta config body.body cf_check ctx in + let _ = eval_function_body config body.meta body.body cf_check ctx in () (** Small helper: return true if the function is a *transparent* unit function diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index be31d865..c7df2eca 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -245,7 +245,7 @@ let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id opt give the value back. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv : typed_value) +let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv : typed_value) (ctx : eval_ctx) : eval_ctx = (* Sanity check *) cassert (not (loans_in_value nv)) meta "TODO: error message"; @@ -267,7 +267,7 @@ let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv (* We sometimes need to reborrow values while giving a value back due: prepare that *) let allow_reborrows = true in let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows meta config allow_reborrows + prepare_reborrows config meta allow_reborrows in (* The visitor to give back the values *) let obj = @@ -440,7 +440,7 @@ let give_back_value (meta : Meta.meta) (config : config) (bid : BorrowId.id) (nv apply_registered_reborrows ctx (** Give back a *modified* symbolic value. *) -let give_back_symbolic_value (meta : Meta.meta) (_config : config) (proj_regions : RegionId.Set.t) +let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) @@ -485,7 +485,7 @@ let give_back_symbolic_value (meta : Meta.meta) (_config : config) (proj_regions end abstraction when ending this abstraction. When doing this, we need to convert the {!avalue} to a {!type:value} by introducing the proper symbolic values. *) -let give_back_avalue_to_same_abstraction (meta : Meta.meta) (_config : config) (bid : BorrowId.id) +let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv : typed_avalue) (nsv : typed_value) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in @@ -588,7 +588,7 @@ let give_back_avalue_to_same_abstraction (meta : Meta.meta) (_config : config) ( we update. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_shared (meta : Meta.meta) _config (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = +let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -739,7 +739,7 @@ let convert_avalue_to_given_back_value (meta : Meta.meta) (av : typed_avalue) : borrows. This kind of internal reshuffling. should be similar to ending abstractions (it is tantamount to ending *sub*-abstractions). *) -let give_back (meta : Meta.meta) (config : config) (l : BorrowId.id) (bc : g_borrow_content) +let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_borrow_content) (ctx : eval_ctx) : eval_ctx = (* Debug *) log#ldebug @@ -763,14 +763,14 @@ let give_back (meta : Meta.meta) (config : config) (l : BorrowId.id) (bc : g_bor (* Check that the corresponding loan is somewhere - purely a sanity check *) cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The corresponding loan should be somewhere"; (* Update the context *) - give_back_value meta config l tv ctx + give_back_value config meta l tv ctx | Concrete (VSharedBorrow l' | VReservedMutBorrow l') -> (* Sanity check *) cassert (l' = l) meta "TODO: error message"; (* Check that the borrow is somewhere - purely a sanity check *) cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The borrow should be somewhere"; (* Update the context *) - give_back_shared meta config l ctx + give_back_shared config meta l ctx | Abstract (AMutBorrow (l', av)) -> (* Sanity check *) cassert (l' = l) meta "TODO: error message"; @@ -783,7 +783,7 @@ let give_back (meta : Meta.meta) (config : config) (l : BorrowId.id) (bc : g_bor *) let sv = convert_avalue_to_given_back_value meta av in (* Update the context *) - give_back_avalue_to_same_abstraction meta config l av + give_back_avalue_to_same_abstraction config meta l av (mk_typed_value_from_symbolic_value sv) ctx | Abstract (ASharedBorrow l') -> @@ -792,12 +792,12 @@ let give_back (meta : Meta.meta) (config : config) (l : BorrowId.id) (bc : g_bor (* Check that the borrow is somewhere - purely a sanity check *) cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The borrow should be somewhere"; (* Update the context *) - give_back_shared meta config l ctx + give_back_shared config meta l ctx | Abstract (AProjSharedBorrow asb) -> (* Sanity check *) cassert (borrow_in_asb l asb) meta "TODO: error message"; (* Update the context *) - give_back_shared meta config l ctx + give_back_shared config meta l ctx | Abstract ( AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedSharedBorrow ) -> @@ -852,7 +852,7 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI perform anything smart and is trusted, and another function for the book-keeping. *) -let rec end_borrow_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) +let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) (allowed_abs : AbstractionId.id option) (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) @@ -900,22 +900,22 @@ let rec end_borrow_aux (meta : Meta.meta) (config : config) (chain : borrow_or_a * inside another borrow *) let allowed_abs' = None in (* End the outer borrows *) - let cc = end_borrows_aux meta config chain allowed_abs' bids in + let cc = end_borrows_aux config meta chain allowed_abs' bids in (* Retry to end the borrow *) - let cc = comp cc (end_borrow_aux meta config chain0 allowed_abs l) in + let cc = comp cc (end_borrow_aux config meta chain0 allowed_abs l) in (* Check and apply *) comp cc cf_check cf ctx | OuterBorrows (Borrow bid) | InnerLoans (Borrow bid) -> let allowed_abs' = None in (* End the outer borrow *) - let cc = end_borrow_aux meta config chain allowed_abs' bid in + let cc = end_borrow_aux config meta chain allowed_abs' bid in (* Retry to end the borrow *) - let cc = comp cc (end_borrow_aux meta config chain0 allowed_abs l) in + let cc = comp cc (end_borrow_aux config meta chain0 allowed_abs l) in (* Check and apply *) comp cc cf_check cf ctx | OuterAbs abs_id -> (* The borrow is inside an abstraction: end the whole abstraction *) - let cf_end_abs = end_abstraction_aux meta config chain abs_id in + let cf_end_abs = end_abstraction_aux config meta chain abs_id in (* Compose with a sanity check *) comp cf_end_abs cf_check cf ctx) | Ok (ctx, None) -> @@ -934,7 +934,7 @@ let rec end_borrow_aux (meta : Meta.meta) (config : config) (chain : borrow_or_a cassert (Option.is_none (get_first_loan_in_value bv)) meta "Borrowed value shouldn't contain loans" | _ -> ()); (* Give back the value *) - let ctx = give_back meta config l bc ctx in + let ctx = give_back config meta l bc ctx in (* Do a sanity check and continue *) let cc = cf_check in (* Save a snapshot of the environment for the name generation *) @@ -942,7 +942,7 @@ let rec end_borrow_aux (meta : Meta.meta) (config : config) (chain : borrow_or_a (* Compose *) cc cf ctx -and end_borrows_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) +and end_borrows_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) (allowed_abs : AbstractionId.id option) (lset : BorrowId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the borrow ids, @@ -950,10 +950,10 @@ and end_borrows_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ * a matter of taste, and may make debugging easier *) let ids = BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in List.fold_left - (fun cf id -> end_borrow_aux meta config chain allowed_abs id cf) + (fun cf id -> end_borrow_aux config meta chain allowed_abs id cf) cf ids -and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) +and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) @@ -991,7 +991,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ ^ " as it is set as non-endable"); (* End the parent abstractions first *) - let cc = end_abstractions_aux meta config chain abs.parents in + let cc = end_abstractions_aux config meta chain abs.parents in let cc = comp_unit cc (fun ctx -> log#ldebug @@ -1003,7 +1003,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ in (* End the loans inside the abstraction *) - let cc = comp cc (end_abstraction_loans meta config chain abs_id) in + let cc = comp cc (end_abstraction_loans config meta chain abs_id) in let cc = comp_unit cc (fun ctx -> log#ldebug @@ -1014,7 +1014,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ in (* End the abstraction itself by redistributing the borrows it contains *) - let cc = comp cc (end_abstraction_borrows meta config chain abs_id) in + let cc = comp cc (end_abstraction_borrows config meta chain abs_id) in (* End the regions owned by the abstraction - note that we don't need to * relookup the abstraction: the set of regions in an abstraction never @@ -1030,7 +1030,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ (* Remove all the references to the id of the current abstraction, and remove * the abstraction itself. * **Rk.**: this is where we synthesize the updated symbolic AST *) - let cc = comp cc (end_abstraction_remove_from_context meta config abs_id) in + let cc = comp cc (end_abstraction_remove_from_context config meta abs_id) in (* Debugging *) let cc = @@ -1052,7 +1052,7 @@ and end_abstraction_aux (meta : Meta.meta) (config : config) (chain : borrow_or_ (* Apply the continuation *) cc cf ctx -and end_abstractions_aux (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) +and end_abstractions_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) (abs_ids : AbstractionId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the abstraction ids, @@ -1060,10 +1060,10 @@ and end_abstractions_aux (meta : Meta.meta) (config : config) (chain : borrow_or * a matter of taste, and may make debugging easier *) let abs_ids = AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in List.fold_left - (fun cf id -> end_abstraction_aux meta config chain id cf) + (fun cf id -> end_abstraction_aux config meta chain id cf) cf abs_ids -and end_abstraction_loans (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) +and end_abstraction_loans (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Lookup the abstraction *) @@ -1081,23 +1081,23 @@ and end_abstraction_loans (meta : Meta.meta) (config : config) (chain : borrow_o (* There are loans: end the corresponding borrows, then recheck *) let cc : cm_fun = match bids with - | Borrow bid -> end_borrow_aux meta config chain None bid - | Borrows bids -> end_borrows_aux meta config chain None bids + | Borrow bid -> end_borrow_aux config meta chain None bid + | Borrows bids -> end_borrows_aux config meta chain None bids in (* Reexplore, looking for loans *) - let cc = comp cc (end_abstraction_loans meta config chain abs_id) in + let cc = comp cc (end_abstraction_loans config meta chain abs_id) in (* Continue *) cc cf ctx | Some (SymbolicValue sv) -> (* There is a proj_loans over a symbolic value: end the proj_borrows * which intersect this proj_loans, then end the proj_loans itself *) - let cc = end_proj_loans_symbolic meta config chain abs_id abs.regions sv in + let cc = end_proj_loans_symbolic config meta chain abs_id abs.regions sv in (* Reexplore, looking for loans *) - let cc = comp cc (end_abstraction_loans meta config chain abs_id) in + let cc = comp cc (end_abstraction_loans config meta chain abs_id) in (* Continue *) cc cf ctx -and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) +and end_abstraction_borrows (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> log#ldebug @@ -1185,13 +1185,13 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow let ctx = update_aborrow meta ek_all bid ended_borrow ctx in (* Give the value back *) let sv = mk_typed_value_from_symbolic_value sv in - give_back_value meta config bid sv ctx + give_back_value config meta bid sv ctx | ASharedBorrow bid -> (* Replace the shared borrow to account for the fact it ended *) let ended_borrow = ABorrow AEndedSharedBorrow in let ctx = update_aborrow meta ek_all bid ended_borrow ctx in (* Give back *) - give_back_shared meta config bid ctx + give_back_shared config meta bid ctx | AProjSharedBorrow asb -> (* Retrieve the borrow ids *) let bids = @@ -1210,7 +1210,7 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow (* Give back the shared borrows *) let ctx = List.fold_left - (fun ctx bid -> give_back_shared meta config bid ctx) + (fun ctx bid -> give_back_shared config meta bid ctx) ctx bids in (* Continue *) @@ -1220,7 +1220,7 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow craise meta "Unexpected" in (* Reexplore *) - end_abstraction_borrows meta config chain abs_id cf ctx + end_abstraction_borrows config meta chain abs_id cf ctx (* There are symbolic borrows: end them, then reexplore *) | FoundAProjBorrows (sv, proj_ty) -> log#ldebug @@ -1234,10 +1234,10 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow let ctx = update_aproj_borrows meta abs.abs_id sv ended_borrow ctx in (* Give back the symbolic value *) let ctx = - give_back_symbolic_value meta config abs.regions proj_ty sv nsv ctx + give_back_symbolic_value config meta abs.regions proj_ty sv nsv ctx in (* Reexplore *) - end_abstraction_borrows meta config chain abs_id cf ctx + end_abstraction_borrows config meta chain abs_id cf ctx (* There are concrete (i.e., not symbolic) borrows in shared values: end them, then reexplore *) | FoundBorrowContent bc -> log#ldebug @@ -1255,7 +1255,7 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow | Error _ -> craise meta "Unreachable" | Ok (ctx, _) -> (* Give back *) - give_back_shared meta config bid ctx) + give_back_shared config meta bid ctx) | VMutBorrow (bid, v) -> ( (* Replace the mut borrow with bottom *) let allow_inner_loans = false in @@ -1266,14 +1266,14 @@ and end_abstraction_borrows (meta : Meta.meta) (config : config) (chain : borrow | Ok (ctx, _) -> (* Give the value back - note that the mut borrow was below a * shared borrow: the value is thus unchanged *) - give_back_value meta config bid v ctx) + give_back_value config meta bid v ctx) | VReservedMutBorrow _ -> craise meta "Unreachable" in (* Reexplore *) - end_abstraction_borrows meta config chain abs_id cf ctx + end_abstraction_borrows config meta chain abs_id cf ctx (** Remove an abstraction from the context, as well as all its references *) -and end_abstraction_remove_from_context (meta : Meta.meta) (_config : config) +and end_abstraction_remove_from_context (_config : config) (meta : Meta.meta) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> let ctx, abs = ctx_remove_abs meta ctx abs_id in @@ -1297,7 +1297,7 @@ and end_abstraction_remove_from_context (meta : Meta.meta) (_config : config) intersecting proj_borrows, either in the concrete context or in an abstraction *) -and end_proj_loans_symbolic (meta : Meta.meta) (config : config) (chain : borrow_or_abs_ids) +and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) (regions : RegionId.Set.t) (sv : symbolic_value) : cm_fun = fun cf ctx -> @@ -1360,7 +1360,7 @@ and end_proj_loans_symbolic (meta : Meta.meta) (config : config) (chain : borrow AbstractionId.Set.empty abs_ids in (* End the abstractions and continue *) - end_abstractions_aux meta config chain abs_ids cf ctx + end_abstractions_aux config meta chain abs_ids cf ctx in (* End the internal borrows projectors and the loans projector *) let cf_end_internal : cm_fun = @@ -1413,35 +1413,35 @@ and end_proj_loans_symbolic (meta : Meta.meta) (config : config) (chain : borrow cf ctx) else (* The borrows proj comes from a different abstraction: end it. *) - let cc = end_abstraction_aux meta config chain abs_id' in + let cc = end_abstraction_aux config meta chain abs_id' in (* Retry ending the projector of loans *) let cc = - comp cc (end_proj_loans_symbolic meta config chain abs_id regions sv) + comp cc (end_proj_loans_symbolic config meta chain abs_id regions sv) in (* Sanity check *) let cc = comp cc cf_check in (* Continue *) cc cf ctx -let end_borrow (meta : Meta.meta ) config : BorrowId.id -> cm_fun = end_borrow_aux meta config [] None +let end_borrow config (meta : Meta.meta ) : BorrowId.id -> cm_fun = end_borrow_aux config meta [] None -let end_borrows (meta : Meta.meta ) config : BorrowId.Set.t -> cm_fun = - end_borrows_aux meta config [] None +let end_borrows config (meta : Meta.meta ) : BorrowId.Set.t -> cm_fun = + end_borrows_aux config meta [] None -let end_abstraction meta config = end_abstraction_aux meta config [] -let end_abstractions meta config = end_abstractions_aux meta config [] +let end_abstraction config meta = end_abstraction_aux config meta [] +let end_abstractions config meta = end_abstractions_aux config meta [] -let end_borrow_no_synth meta config id ctx = - get_cf_ctx_no_synth meta (end_borrow meta config id) ctx +let end_borrow_no_synth config meta id ctx = + get_cf_ctx_no_synth meta (end_borrow config meta id) ctx -let end_borrows_no_synth meta config ids ctx = - get_cf_ctx_no_synth meta (end_borrows meta config ids) ctx +let end_borrows_no_synth config meta ids ctx = + get_cf_ctx_no_synth meta (end_borrows config meta ids) ctx -let end_abstraction_no_synth meta config id ctx = - get_cf_ctx_no_synth meta (end_abstraction meta config id) ctx +let end_abstraction_no_synth config meta id ctx = + get_cf_ctx_no_synth meta (end_abstraction config meta id) ctx -let end_abstractions_no_synth meta config ids ctx = - get_cf_ctx_no_synth meta (end_abstractions meta config ids) ctx +let end_abstractions_no_synth config meta ids ctx = + get_cf_ctx_no_synth meta (end_abstractions config meta ids) ctx (** Helper function: see {!activate_reserved_mut_borrow}. @@ -1532,7 +1532,7 @@ let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) cf ctx (** Promote a reserved mut borrow to a mut borrow. *) -let rec promote_reserved_mut_borrow (meta : Meta.meta) (config : config) (l : BorrowId.id) : cm_fun +let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Lookup the value *) @@ -1550,11 +1550,11 @@ let rec promote_reserved_mut_borrow (meta : Meta.meta) (config : config) (l : Bo (* End the loans *) let cc = match lc with - | VSharedLoan (bids, _) -> end_borrows meta config bids - | VMutLoan bid -> end_borrow meta config bid + | VSharedLoan (bids, _) -> end_borrows config meta bids + | VMutLoan bid -> end_borrow config meta bid in (* Recursive call *) - let cc = comp cc (promote_reserved_mut_borrow meta config l) in + let cc = comp cc (promote_reserved_mut_borrow config meta l) in (* Continue *) cc cf ctx | None -> @@ -1570,7 +1570,7 @@ let rec promote_reserved_mut_borrow (meta : Meta.meta) (config : config) (l : Bo (* End the borrows which borrow from the value, at the exception of the borrow we want to promote *) let bids = BorrowId.Set.remove l bids in - let cc = end_borrows meta config bids in + let cc = end_borrows config meta bids in (* Promote the loan - TODO: this will fail if the value contains * any loans. In practice, it shouldn't, but we could also * look for loans inside the value and end them before promoting diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index 95a27245..fbd2cd7a 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -15,30 +15,30 @@ val reborrow_shared : Meta.meta -> BorrowId.id -> BorrowId.id -> eval_ctx -> eva If the borrow is inside another borrow/an abstraction or contains loans, [end_borrow] will end those borrows/abstractions/loans first. *) -val end_borrow : Meta.meta -> config -> BorrowId.id -> cm_fun +val end_borrow : config -> Meta.meta -> BorrowId.id -> cm_fun (** End a set of borrows identified by their ids, while preserving the invariants. *) -val end_borrows : Meta.meta -> config -> BorrowId.Set.t -> cm_fun +val end_borrows : config -> Meta.meta -> BorrowId.Set.t -> cm_fun (** End an abstraction while preserving the invariants. *) -val end_abstraction : Meta.meta -> config -> AbstractionId.id -> cm_fun +val end_abstraction : config -> Meta.meta -> AbstractionId.id -> cm_fun (** End a set of abstractions while preserving the invariants. *) -val end_abstractions : Meta.meta -> config -> AbstractionId.Set.t -> cm_fun +val end_abstractions : config -> Meta.meta -> AbstractionId.Set.t -> cm_fun (** End a borrow and return the resulting environment, ignoring synthesis *) -val end_borrow_no_synth : Meta.meta -> config -> BorrowId.id -> eval_ctx -> eval_ctx +val end_borrow_no_synth : config -> Meta.meta -> BorrowId.id -> eval_ctx -> eval_ctx (** End a set of borrows and return the resulting environment, ignoring synthesis *) -val end_borrows_no_synth : Meta.meta -> config -> BorrowId.Set.t -> eval_ctx -> eval_ctx +val end_borrows_no_synth : config -> Meta.meta -> BorrowId.Set.t -> eval_ctx -> eval_ctx (** End an abstraction and return the resulting environment, ignoring synthesis *) val end_abstraction_no_synth : - Meta.meta -> config -> AbstractionId.id -> eval_ctx -> eval_ctx + config -> Meta.meta -> AbstractionId.id -> eval_ctx -> eval_ctx (** End a set of abstractions and return the resulting environment, ignoring synthesis *) val end_abstractions_no_synth : - Meta.meta -> config -> AbstractionId.Set.t -> eval_ctx -> eval_ctx + config -> Meta.meta -> AbstractionId.Set.t -> eval_ctx -> eval_ctx (** Promote a reserved mut borrow to a mut borrow, while preserving the invariants. @@ -49,7 +49,7 @@ val end_abstractions_no_synth : the corresponding shared loan with a mutable loan (after having ended the other shared borrows which point to this loan). *) -val promote_reserved_mut_borrow : Meta.meta -> config -> BorrowId.id -> cm_fun +val promote_reserved_mut_borrow : config -> Meta.meta -> BorrowId.id -> cm_fun (** Transform an abstraction to an abstraction where the values are not structured. diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 9448f3e8..2f886714 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -48,7 +48,7 @@ type proj_kind = LoanProj | BorrowProj Note that 2. and 3. may have a little bit of duplicated code, but hopefully it would make things clearer. *) -let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : config) +let apply_symbolic_expansion_to_target_avalues (config : config) (meta : Meta.meta) (allow_reborrows : bool) (proj_kind : proj_kind) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = @@ -56,7 +56,7 @@ let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : conf let check_symbolic_no_ended = false in (* Prepare reborrows registration *) let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows meta config allow_reborrows + prepare_reborrows config meta allow_reborrows in (* Visitor to apply the expansion *) let obj = @@ -146,11 +146,11 @@ let apply_symbolic_expansion_to_target_avalues (meta : Meta.meta) (config : conf (** Auxiliary function. Apply a symbolic expansion to avalues in a context. *) -let apply_symbolic_expansion_to_avalues (meta : Meta.meta) (config : config) +let apply_symbolic_expansion_to_avalues (config : config) (meta : Meta.meta) (allow_reborrows : bool) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = let apply_expansion proj_kind ctx = - apply_symbolic_expansion_to_target_avalues meta config allow_reborrows proj_kind + apply_symbolic_expansion_to_target_avalues config meta allow_reborrows proj_kind original_sv expansion ctx in (* First target the loan projectors, then the borrow projectors *) @@ -187,7 +187,7 @@ let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) (original_s (* Return *) ctx -let apply_symbolic_expansion_non_borrow (meta : Meta.meta) (config : config) +let apply_symbolic_expansion_non_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = (* Apply the expansion to non-abstraction values *) @@ -196,7 +196,7 @@ let apply_symbolic_expansion_non_borrow (meta : Meta.meta) (config : config) let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in (* Apply the expansion to abstraction values *) let allow_reborrows = false in - apply_symbolic_expansion_to_avalues meta config allow_reborrows original_sv + apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv expansion ctx (** Compute the expansion of a non-assumed (i.e.: not [Box], etc.) @@ -275,7 +275,7 @@ let compute_expanded_symbolic_adt_value (meta : Meta.meta) (expand_enumerations craise meta "compute_expanded_symbolic_adt_value: unexpected combination" -let expand_symbolic_value_shared_borrow (meta : Meta.meta) (config : config) +let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) (ref_ty : rty) : cm_fun = fun cf ctx -> @@ -380,7 +380,7 @@ let expand_symbolic_value_shared_borrow (meta : Meta.meta) (config : config) let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = - apply_symbolic_expansion_to_avalues meta config allow_reborrows original_sv see + apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv see ctx in (* Call the continuation *) @@ -390,7 +390,7 @@ let expand_symbolic_value_shared_borrow (meta : Meta.meta) (config : config) expr (** TODO: simplify and merge with the other expansion function *) -let expand_symbolic_value_borrow (meta : Meta.meta) (config : config) +let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) (region : region) (ref_ty : rty) (rkind : ref_kind) : cm_fun = fun cf ctx -> @@ -413,7 +413,7 @@ let expand_symbolic_value_borrow (meta : Meta.meta) (config : config) (* Expand the symbolic avalues *) let allow_reborrows = true in let ctx = - apply_symbolic_expansion_to_avalues meta config allow_reborrows original_sv + apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv see ctx in (* Apply the continuation *) @@ -422,7 +422,7 @@ let expand_symbolic_value_borrow (meta : Meta.meta) (config : config) S.synthesize_symbolic_expansion_no_branching meta original_sv original_sv_place see expr | RShared -> - expand_symbolic_value_shared_borrow meta config original_sv original_sv_place + expand_symbolic_value_shared_borrow config meta original_sv original_sv_place ref_ty cf ctx (** A small helper. @@ -441,7 +441,7 @@ let expand_symbolic_value_borrow (meta : Meta.meta) (config : config) We need this continuation separately (i.e., we can't compose it with the continuations in [see_cf_l]) because we perform a join *before* calling it. *) -let apply_branching_symbolic_expansions_non_borrow (meta : Meta.meta) (config : config) +let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = @@ -457,7 +457,7 @@ let apply_branching_symbolic_expansions_non_borrow (meta : Meta.meta) (config : let ctx = match see_opt with | None -> ctx - | Some see -> apply_symbolic_expansion_non_borrow meta config sv see ctx + | Some see -> apply_symbolic_expansion_non_borrow config meta sv see ctx in (* Debug *) log#ldebug @@ -484,7 +484,7 @@ let apply_branching_symbolic_expansions_non_borrow (meta : Meta.meta) (config : let seel = List.map fst see_cf_l in S.synthesize_symbolic_expansion meta sv sv_place seel subterms -let expand_symbolic_bool (meta : Meta.meta) (config : config) (sv : symbolic_value) +let expand_symbolic_bool (config : config) (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) (cf_true : st_cm_fun) (cf_false : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> @@ -498,10 +498,10 @@ let expand_symbolic_bool (meta : Meta.meta) (config : config) (sv : symbolic_val let see_false = SeLiteral (VBool false) in let seel = [ (Some see_true, cf_true); (Some see_false, cf_false) ] in (* Apply the symbolic expansion (this also outputs the updated symbolic AST) *) - apply_branching_symbolic_expansions_non_borrow meta config original_sv + apply_branching_symbolic_expansions_non_borrow config meta original_sv original_sv_place seel cf_after_join ctx -let expand_symbolic_value_no_branching (meta : Meta.meta) (config : config) (sv : symbolic_value) +let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) : cm_fun = fun cf ctx -> (* Debug *) @@ -530,7 +530,7 @@ let expand_symbolic_value_no_branching (meta : Meta.meta) (config : config) (sv let see = Collections.List.to_cons_nil seel in (* Apply in the context *) let ctx = - apply_symbolic_expansion_non_borrow meta config original_sv see ctx + apply_symbolic_expansion_non_borrow config meta original_sv see ctx in (* Call the continuation *) let expr = cf ctx in @@ -539,7 +539,7 @@ let expand_symbolic_value_no_branching (meta : Meta.meta) (config : config) (sv original_sv_place see expr (* Borrows *) | TRef (region, ref_ty, rkind) -> - expand_symbolic_value_borrow meta config original_sv original_sv_place region + expand_symbolic_value_borrow config meta original_sv original_sv_place region ref_ty rkind cf ctx | _ -> craise @@ -562,7 +562,7 @@ let expand_symbolic_value_no_branching (meta : Meta.meta) (config : config) (sv (* Continue *) cc cf ctx -let expand_symbolic_adt (meta : Meta.meta) (config : config) (sv : symbolic_value) +let expand_symbolic_adt (config : config) (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) (cf_branches : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> @@ -584,12 +584,12 @@ let expand_symbolic_adt (meta : Meta.meta) (config : config) (sv : symbolic_valu in (* Apply *) let seel = List.map (fun see -> (Some see, cf_branches)) seel in - apply_branching_symbolic_expansions_non_borrow meta config original_sv + apply_branching_symbolic_expansions_non_borrow config meta original_sv original_sv_place seel cf_after_join ctx | _ -> craise meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) -let expand_symbolic_int (meta : Meta.meta) (config : config) (sv : symbolic_value) +let expand_symbolic_int (config : config) (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) (int_type : integer_type) (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = @@ -609,7 +609,7 @@ let expand_symbolic_int (meta : Meta.meta) (config : config) (sv : symbolic_valu in let seel = List.append seel [ (None, otherwise) ] in (* Then expand and evaluate - this generates the proper symbolic AST *) - apply_branching_symbolic_expansions_non_borrow meta config sv sv_place seel + apply_branching_symbolic_expansions_non_borrow config meta sv sv_place seel cf_after_join (** Expand all the symbolic values which contain borrows. @@ -620,7 +620,7 @@ let expand_symbolic_int (meta : Meta.meta) (config : config) (sv : symbolic_valu an enumeration with strictly more than one variant, a slice, etc.) or if we need to expand a recursive type (because this leads to looping). *) -let greedy_expand_symbolics_with_borrows (meta : Meta.meta) (config : config) : cm_fun = +let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : cm_fun = fun cf ctx -> (* The visitor object, to look for symbolic values in the concrete environment *) let obj = @@ -677,10 +677,10 @@ let greedy_expand_symbolics_with_borrows (meta : Meta.meta) (config : config) : (option [greedy_expand_symbolics_with_borrows] of \ [config]): " ^ name_to_string ctx def.name) - else expand_symbolic_value_no_branching meta config sv None + else expand_symbolic_value_no_branching config meta sv None | TAdt ((TTuple | TAssumed TBox), _) | TRef (_, _, _) -> (* Ok *) - expand_symbolic_value_no_branching meta config sv None + expand_symbolic_value_no_branching config meta sv None | TAdt (TAssumed (TArray | TSlice | TStr), _) -> (* We can't expand those *) craise @@ -695,9 +695,9 @@ let greedy_expand_symbolics_with_borrows (meta : Meta.meta) (config : config) : (* Apply *) expand cf ctx -let greedy_expand_symbolic_values (meta : Meta.meta) (config : config) : cm_fun = +let greedy_expand_symbolic_values (config : config) (meta : Meta.meta) : cm_fun = fun cf ctx -> if Config.greedy_expand_symbolics_with_borrows then ( log#ldebug (lazy "greedy_expand_symbolic_values"); - greedy_expand_symbolics_with_borrows meta config cf ctx) + greedy_expand_symbolics_with_borrows config meta cf ctx) else cf ctx diff --git a/compiler/InterpreterExpansion.mli b/compiler/InterpreterExpansion.mli index 3540d04c..8b0b386a 100644 --- a/compiler/InterpreterExpansion.mli +++ b/compiler/InterpreterExpansion.mli @@ -12,11 +12,11 @@ type proj_kind = LoanProj | BorrowProj This function does *not* update the synthesis. *) val apply_symbolic_expansion_non_borrow : - Meta.meta -> config -> symbolic_value -> symbolic_expansion -> eval_ctx -> eval_ctx + config -> Meta.meta -> symbolic_value -> symbolic_expansion -> eval_ctx -> eval_ctx (** Expand a symhbolic value, without branching *) val expand_symbolic_value_no_branching : - Meta.meta -> config -> symbolic_value -> SA.mplace option -> cm_fun + config -> Meta.meta -> symbolic_value -> SA.mplace option -> cm_fun (** Expand a symbolic enumeration (leads to branching if the enumeration has more than one variant). @@ -32,7 +32,7 @@ val expand_symbolic_value_no_branching : then call it). *) val expand_symbolic_adt : - Meta.meta -> config -> symbolic_value -> SA.mplace option -> st_cm_fun -> st_m_fun -> m_fun + config -> Meta.meta -> symbolic_value -> SA.mplace option -> st_cm_fun -> st_m_fun -> m_fun (** Expand a symbolic boolean. @@ -41,8 +41,8 @@ val expand_symbolic_adt : parameter (here, there are exactly two branches). *) val expand_symbolic_bool : - Meta.meta -> - config -> + config -> + Meta.meta -> symbolic_value -> SA.mplace option -> st_cm_fun -> @@ -70,8 +70,8 @@ val expand_symbolic_bool : switch. The continuation is thus for the execution *after* the switch. *) val expand_symbolic_int : - Meta.meta -> - config -> + config -> + Meta.meta -> symbolic_value -> SA.mplace option -> integer_type -> @@ -83,4 +83,4 @@ val expand_symbolic_int : (** If this mode is activated through the [config], greedily expand the symbolic values which need to be expanded. See {!type:Contexts.config} for more information. *) -val greedy_expand_symbolic_values : Meta.meta -> config -> cm_fun +val greedy_expand_symbolic_values : config -> Meta.meta -> cm_fun diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index f82c7130..d74e0751 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -24,7 +24,7 @@ let log = Logging.expressions_log Note that the place should have been prepared so that there are no remaining loans. *) -let expand_primitively_copyable_at_place (meta : Meta.meta) (config : config) +let expand_primitively_copyable_at_place (config : config) (meta : Meta.meta) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Small helper *) @@ -37,7 +37,7 @@ let expand_primitively_copyable_at_place (meta : Meta.meta) (config : config) | None -> cf ctx | Some sv -> let cc = - expand_symbolic_value_no_branching meta config sv (Some (mk_mplace meta p ctx)) + expand_symbolic_value_no_branching config meta sv (Some (mk_mplace meta p ctx)) in comp cc expand cf ctx in @@ -60,19 +60,19 @@ let read_place (meta : Meta.meta) (access : access_kind) (p : place) (cf : typed (* Call the continuation *) cf v ctx -let access_rplace_reorganize_and_read (meta : Meta.meta) (config : config) +let access_rplace_reorganize_and_read (config : config) (meta : Meta.meta) (expand_prim_copy : bool) (access : access_kind) (p : place) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Make sure we can evaluate the path *) - let cc = update_ctx_along_read_place meta config access p in + let cc = update_ctx_along_read_place config meta access p in (* End the proper loans at the place itself *) - let cc = comp cc (end_loans_at_place meta config access p) in + let cc = comp cc (end_loans_at_place config meta access p) in (* Expand the copyable values which contain borrows (which are necessarily shared * borrows) *) let cc = if expand_prim_copy then - comp cc (expand_primitively_copyable_at_place meta config access p) + comp cc (expand_primitively_copyable_at_place config meta access p) else cc in (* Read the place - note that this checks that the value doesn't contain bottoms *) @@ -80,10 +80,10 @@ let access_rplace_reorganize_and_read (meta : Meta.meta) (config : config) (* Compose *) comp cc read_place cf ctx -let access_rplace_reorganize (meta : Meta.meta) (config : config) (expand_prim_copy : bool) +let access_rplace_reorganize (config : config) (meta : Meta.meta) (expand_prim_copy : bool) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> - access_rplace_reorganize_and_read meta config expand_prim_copy access p + access_rplace_reorganize_and_read config meta expand_prim_copy access p (fun _v -> cf) ctx @@ -225,7 +225,7 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) what we do in the formalization (because we don't enforce the same constraints as MIR in the formalization). *) -let prepare_eval_operand_reorganize (meta : Meta.meta) (config : config) (op : operand) : cm_fun = +let prepare_eval_operand_reorganize (config : config) (meta : Meta.meta) (op : operand) : cm_fun = fun cf ctx -> let prepare : cm_fun = fun cf ctx -> @@ -238,18 +238,18 @@ let prepare_eval_operand_reorganize (meta : Meta.meta) (config : config) (op : o let access = Read in (* Expand the symbolic values, if necessary *) let expand_prim_copy = true in - access_rplace_reorganize meta config expand_prim_copy access p cf ctx + access_rplace_reorganize config meta expand_prim_copy access p cf ctx | Move p -> (* Access the value *) let access = Move in let expand_prim_copy = false in - access_rplace_reorganize meta config expand_prim_copy access p cf ctx + access_rplace_reorganize config meta expand_prim_copy access p cf ctx in (* Apply *) prepare cf ctx (** Evaluate an operand, without reorganizing the context before *) -let eval_operand_no_reorganize (meta : Meta.meta) (config : config) (op : operand) +let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operand) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) @@ -359,7 +359,7 @@ let eval_operand_no_reorganize (meta : Meta.meta) (config : config) (op : operan (* Compose and apply *) comp cc move cf ctx -let eval_operand (meta : Meta.meta) (config : config) (op : operand) (cf : typed_value -> m_fun) : +let eval_operand (config : config) (meta : Meta.meta) (op : operand) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) @@ -369,34 +369,34 @@ let eval_operand (meta : Meta.meta) (config : config) (op : operand) (cf : type ^ eval_ctx_to_string meta ctx ^ "\n")); (* We reorganize the context, then evaluate the operand *) comp - (prepare_eval_operand_reorganize meta config op) - (eval_operand_no_reorganize meta config op) + (prepare_eval_operand_reorganize config meta op) + (eval_operand_no_reorganize config meta op) cf ctx (** Small utility. See [prepare_eval_operand_reorganize]. *) -let prepare_eval_operands_reorganize (meta : Meta.meta) (config : config) (ops : operand list) : +let prepare_eval_operands_reorganize (config : config) (meta : Meta.meta) (ops : operand list) : cm_fun = - fold_left_apply_continuation (prepare_eval_operand_reorganize meta config) ops + fold_left_apply_continuation (prepare_eval_operand_reorganize config meta) ops (** Evaluate several operands. *) -let eval_operands (meta : Meta.meta) (config : config) (ops : operand list) +let eval_operands (config : config) (meta : Meta.meta) (ops : operand list) (cf : typed_value list -> m_fun) : m_fun = fun ctx -> (* Prepare the operands *) - let prepare = prepare_eval_operands_reorganize meta config ops in + let prepare = prepare_eval_operands_reorganize config meta ops in (* Evaluate the operands *) let eval = - fold_left_list_apply_continuation (eval_operand_no_reorganize meta config) ops + fold_left_list_apply_continuation (eval_operand_no_reorganize config meta) ops in (* Compose and apply *) comp prepare eval cf ctx -let eval_two_operands (meta : Meta.meta) (config : config) (op1 : operand) (op2 : operand) +let eval_two_operands (config : config) (meta : Meta.meta) (op1 : operand) (op2 : operand) (cf : typed_value * typed_value -> m_fun) : m_fun = - let eval_op = eval_operands meta config [ op1; op2 ] in + let eval_op = eval_operands config meta [ op1; op2 ] in let use_res cf res = match res with | [ v1; v2 ] -> cf (v1, v2) @@ -404,10 +404,10 @@ let eval_two_operands (meta : Meta.meta) (config : config) (op1 : operand) (op2 in comp eval_op use_res cf -let eval_unary_op_concrete (meta : Meta.meta) (config : config) (unop : unop) (op : operand) +let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operand *) - let eval_op = eval_operand meta config op in + let eval_op = eval_operand config meta op in (* Apply the unop *) let apply cf (v : typed_value) : m_fun = match (unop, v.value) with @@ -452,11 +452,11 @@ let eval_unary_op_concrete (meta : Meta.meta) (config : config) (unop : unop) (o in comp eval_op apply cf -let eval_unary_op_symbolic (meta : Meta.meta) (config : config) (unop : unop) (op : operand) +let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operand *) - let eval_op = eval_operand meta config op in + let eval_op = eval_operand config meta op in (* Generate a fresh symbolic value to store the result *) let apply cf (v : typed_value) : m_fun = fun ctx -> @@ -479,11 +479,11 @@ let eval_unary_op_symbolic (meta : Meta.meta) (config : config) (unop : unop) (o (* Compose and apply *) comp eval_op apply cf ctx -let eval_unary_op (meta : Meta.meta) (config : config) (unop : unop) (op : operand) +let eval_unary_op (config : config) (meta : Meta.meta) (unop : unop) (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with - | ConcreteMode -> eval_unary_op_concrete meta config unop op cf - | SymbolicMode -> eval_unary_op_symbolic meta config unop op cf + | ConcreteMode -> eval_unary_op_concrete config meta unop op cf + | SymbolicMode -> eval_unary_op_symbolic config meta unop op cf (** Small helper for [eval_binary_op_concrete]: computes the result of applying the binop *after* the operands have been successfully evaluated @@ -558,10 +558,10 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typ | Ne | Eq -> craise meta "Unreachable") | _ -> craise meta "Invalid inputs for binop" -let eval_binary_op_concrete (meta : Meta.meta) (config : config) (binop : binop) (op1 : operand) +let eval_binary_op_concrete (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operands *) - let eval_ops = eval_two_operands meta config op1 op2 in + let eval_ops = eval_two_operands config meta op1 op2 in (* Compute the result of the binop *) let compute cf (res : typed_value * typed_value) = let v1, v2 = res in @@ -570,11 +570,11 @@ let eval_binary_op_concrete (meta : Meta.meta) (config : config) (binop : binop) (* Compose and apply *) comp eval_ops compute cf -let eval_binary_op_symbolic (meta : Meta.meta) (config : config) (binop : binop) (op1 : operand) +let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operands *) - let eval_ops = eval_two_operands meta config op1 op2 in + let eval_ops = eval_two_operands config meta op1 op2 in (* Compute the result of applying the binop *) let compute cf ((v1, v2) : typed_value * typed_value) : m_fun = fun ctx -> @@ -617,13 +617,13 @@ let eval_binary_op_symbolic (meta : Meta.meta) (config : config) (binop : binop) (* Compose and apply *) comp eval_ops compute cf ctx -let eval_binary_op (meta : Meta.meta) (config : config) (binop : binop) (op1 : operand) +let eval_binary_op (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with - | ConcreteMode -> eval_binary_op_concrete meta config binop op1 op2 cf - | SymbolicMode -> eval_binary_op_symbolic meta config binop op1 op2 cf + | ConcreteMode -> eval_binary_op_concrete config meta binop op1 op2 cf + | SymbolicMode -> eval_binary_op_symbolic config meta binop op1 op2 cf -let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : borrow_kind) +let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) (bkind : borrow_kind) (cf : typed_value -> m_fun) : m_fun = fun ctx -> match bkind with @@ -644,7 +644,7 @@ let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : bo let expand_prim_copy = false in let prepare = - access_rplace_reorganize_and_read meta config expand_prim_copy access p + access_rplace_reorganize_and_read config meta expand_prim_copy access p in (* Evaluate the borrowing operation *) let eval (cf : typed_value -> m_fun) (v : typed_value) : m_fun = @@ -694,7 +694,7 @@ let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : bo let access = Write in let expand_prim_copy = false in let prepare = - access_rplace_reorganize_and_read meta config expand_prim_copy access p + access_rplace_reorganize_and_read config meta expand_prim_copy access p in (* Evaluate the borrowing operation *) let eval (cf : typed_value -> m_fun) (v : typed_value) : m_fun = @@ -715,10 +715,10 @@ let eval_rvalue_ref (meta : Meta.meta) (config : config) (p : place) (bkind : bo (* Compose and apply *) comp prepare eval cf ctx -let eval_rvalue_aggregate (meta : Meta.meta) (config : config) (aggregate_kind : aggregate_kind) +let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : aggregate_kind) (ops : operand list) (cf : typed_value -> m_fun) : m_fun = (* Evaluate the operands *) - let eval_ops = eval_operands meta config ops in + let eval_ops = eval_operands config meta ops in (* Compute the value *) let compute (cf : typed_value -> m_fun) (values : typed_value list) : m_fun = fun ctx -> @@ -782,7 +782,7 @@ let eval_rvalue_aggregate (meta : Meta.meta) (config : config) (aggregate_kind : (* Compose and apply *) comp eval_ops compute cf -let eval_rvalue_not_global (meta : Meta.meta) (config : config) (rvalue : rvalue) +let eval_rvalue_not_global (config : config) (meta : Meta.meta) (rvalue : rvalue) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> log#ldebug (lazy "eval_rvalue"); @@ -794,12 +794,12 @@ let eval_rvalue_not_global (meta : Meta.meta) (config : config) (rvalue : rvalue let comp_wrap f = comp f wrap_in_result cf in (* Delegate to the proper auxiliary function *) match rvalue with - | Use op -> comp_wrap (eval_operand meta config op) ctx - | RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref meta config p bkind) ctx - | UnaryOp (unop, op) -> eval_unary_op meta config unop op cf ctx - | BinaryOp (binop, op1, op2) -> eval_binary_op meta config binop op1 op2 cf ctx + | Use op -> comp_wrap (eval_operand config meta op) ctx + | RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config meta p bkind) ctx + | UnaryOp (unop, op) -> eval_unary_op config meta unop op cf ctx + | BinaryOp (binop, op1, op2) -> eval_binary_op config meta binop op1 op2 cf ctx | Aggregate (aggregate_kind, ops) -> - comp_wrap (eval_rvalue_aggregate meta config aggregate_kind ops) ctx + comp_wrap (eval_rvalue_aggregate config meta aggregate_kind ops) ctx | Discriminant _ -> craise meta @@ -807,11 +807,11 @@ let eval_rvalue_not_global (meta : Meta.meta) (config : config) (rvalue : rvalue the AST" | Global _ -> craise meta "Unreachable" -let eval_fake_read (meta : Meta.meta) (config : config) (p : place) : cm_fun = +let eval_fake_read (config : config) (meta : Meta.meta) (p : place) : cm_fun = fun cf ctx -> let expand_prim_copy = false in let cf_prepare cf = - access_rplace_reorganize_and_read meta config expand_prim_copy Read p cf + access_rplace_reorganize_and_read config meta expand_prim_copy Read p cf in let cf_continue cf v : m_fun = fun ctx -> diff --git a/compiler/InterpreterExpressions.mli b/compiler/InterpreterExpressions.mli index 69455682..76627c40 100644 --- a/compiler/InterpreterExpressions.mli +++ b/compiler/InterpreterExpressions.mli @@ -31,7 +31,7 @@ val read_place : Meta.meta -> access_kind -> place -> (typed_value -> m_fun) -> primitively copyable and contain borrows. *) val access_rplace_reorganize_and_read : - Meta.meta -> config -> bool -> access_kind -> place -> (typed_value -> m_fun) -> m_fun + config -> Meta.meta -> bool -> access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Evaluate an operand. @@ -42,11 +42,11 @@ val access_rplace_reorganize_and_read : of the environment, before evaluating all the operands at once. Use {!eval_operands} instead. *) -val eval_operand : Meta.meta -> config -> operand -> (typed_value -> m_fun) -> m_fun +val eval_operand : config -> Meta.meta -> operand -> (typed_value -> m_fun) -> m_fun (** Evaluate several operands at once. *) val eval_operands : - Meta.meta -> config -> operand list -> (typed_value list -> m_fun) -> m_fun + config -> Meta.meta -> operand list -> (typed_value list -> m_fun) -> m_fun (** Evaluate an rvalue which is not a global (globals are handled elsewhere). @@ -56,7 +56,7 @@ val eval_operands : reads should have been eliminated from the AST. *) val eval_rvalue_not_global : - Meta.meta -> config -> rvalue -> ((typed_value, eval_error) result -> m_fun) -> m_fun + config -> Meta.meta -> rvalue -> ((typed_value, eval_error) result -> m_fun) -> m_fun (** Evaluate a fake read (update the context so that we can read a place) *) -val eval_fake_read : Meta.meta -> config -> place -> cm_fun +val eval_fake_read : config -> Meta.meta -> place -> cm_fun diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 98aa0e14..4d4b709e 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -75,7 +75,7 @@ let eval_loop_symbolic (config : config) (meta : meta) (* Compute the fixed point at the loop entrance *) let fp_ctx, fixed_ids, rg_to_abs = - compute_loop_entry_fixed_point meta config loop_id eval_loop_body ctx + compute_loop_entry_fixed_point config meta loop_id eval_loop_body ctx in (* Debug *) @@ -125,7 +125,7 @@ let eval_loop_symbolic (config : config) (meta : meta) - src ctx (fixed-point ctx)" ^ eval_ctx_to_string meta fp_ctx ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string meta ctx)); let end_expr : SymbolicAst.expression option = - match_ctx_with_target meta config loop_id true fp_bl_corresp fp_input_svalues + match_ctx_with_target config meta loop_id true fp_bl_corresp fp_input_svalues fixed_ids fp_ctx cf ctx in log#ldebug @@ -158,7 +158,7 @@ let eval_loop_symbolic (config : config) (meta : meta) - src ctx (fixed-point ctx)" ^ eval_ctx_to_string meta fp_ctx ^ "\n\n-tgt ctx (ctx at continue):\n" ^ eval_ctx_to_string meta ctx)); let cc = - match_ctx_with_target meta config loop_id false fp_bl_corresp + match_ctx_with_target config meta loop_id false fp_bl_corresp fp_input_svalues fixed_ids fp_ctx in cc cf ctx diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 508d0f0c..ef2c5698 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -437,7 +437,7 @@ let prepare_ashared_loans_no_synth (meta : Meta.meta) (loop_id : LoopId.id) (ctx eval_ctx = get_cf_ctx_no_synth meta (prepare_ashared_loans meta (Some loop_id)) ctx -let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id : LoopId.id) +let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id : LoopId.id) (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : eval_ctx * ids_sets * abs RegionGroupId.Map.t = (* The continuation for when we exit the loop - we register the @@ -510,10 +510,10 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (* End those borrows and abstractions *) let end_borrows_abs blids aids ctx = let ctx = - InterpreterBorrows.end_borrows_no_synth meta config blids ctx + InterpreterBorrows.end_borrows_no_synth config meta blids ctx in let ctx = - InterpreterBorrows.end_abstractions_no_synth meta config aids ctx + InterpreterBorrows.end_abstractions_no_synth config meta aids ctx in ctx in @@ -544,7 +544,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id (* Join the context with the context at the loop entry *) let (_, _), ctx2 = - loop_join_origin_with_continue_ctxs meta config loop_id fixed_ids ctx1 !ctxs + loop_join_origin_with_continue_ctxs config meta loop_id fixed_ids ctx1 !ctxs in ctxs := []; ctx2 @@ -699,7 +699,7 @@ let compute_loop_entry_fixed_point (meta : Meta.meta) (config : config) (loop_id abs.kind = SynthInput rg_id) meta "TODO : error message "; (* End this abstraction *) let ctx = - InterpreterBorrows.end_abstraction_no_synth meta config abs_id ctx + InterpreterBorrows.end_abstraction_no_synth config meta abs_id ctx in (* Explore the context, and check which abstractions are not there anymore *) let ids, _ = compute_ctx_ids ctx in diff --git a/compiler/InterpreterLoopsFixedPoint.mli b/compiler/InterpreterLoopsFixedPoint.mli index d727e9bd..4568bf79 100644 --- a/compiler/InterpreterLoopsFixedPoint.mli +++ b/compiler/InterpreterLoopsFixedPoint.mli @@ -77,8 +77,8 @@ val prepare_ashared_loans : Meta.meta -> loop_id option -> Cps.cm_fun the values which are read or modified (some symbolic values may be ignored). *) val compute_loop_entry_fixed_point : - Meta.meta -> - config -> + config -> + Meta.meta -> loop_id -> Cps.st_cm_fun -> eval_ctx -> diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index b8d5094b..c4709b7e 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -636,7 +636,7 @@ let refresh_abs (old_abs : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = in { ctx with env } -let loop_join_origin_with_continue_ctxs (meta : Meta.meta) (config : config) (loop_id : LoopId.id) +let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (old_ctx : eval_ctx) (ctxl : eval_ctx list) : (eval_ctx * eval_ctx list) * eval_ctx = (* # Join with the new contexts, one by one @@ -657,9 +657,9 @@ let loop_join_origin_with_continue_ctxs (meta : Meta.meta) (config : config) (lo let ctx = match err with | LoanInRight bid -> - InterpreterBorrows.end_borrow_no_synth meta config bid ctx + InterpreterBorrows.end_borrow_no_synth config meta bid ctx | LoansInRight bids -> - InterpreterBorrows.end_borrows_no_synth meta config bids ctx + InterpreterBorrows.end_borrows_no_synth config meta bids ctx | AbsInRight _ | AbsInLeft _ | LoanInLeft _ | LoansInLeft _ -> craise meta "Unexpected" in diff --git a/compiler/InterpreterLoopsJoinCtxs.mli b/compiler/InterpreterLoopsJoinCtxs.mli index e79e6a25..d92b3750 100644 --- a/compiler/InterpreterLoopsJoinCtxs.mli +++ b/compiler/InterpreterLoopsJoinCtxs.mli @@ -104,8 +104,8 @@ val join_ctxs : Meta.meta -> loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_ - [ctxl] *) val loop_join_origin_with_continue_ctxs : - Meta.meta -> config -> + Meta.meta -> loop_id -> ids_sets -> eval_ctx -> diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 033e51c1..2e700c50 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -1400,7 +1400,7 @@ let ctxs_are_equivalent (meta : Meta.meta) (fixed_ids : ids_sets) (ctx0 : eval_c (match_ctxs meta check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx0 ctx1) -let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id : LoopId.id) +let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (src_ctx : eval_ctx) : cm_fun = fun cf tgt_ctx -> (* Debug *) @@ -1528,8 +1528,8 @@ let prepare_match_ctx_with_target (meta : Meta.meta) (config : config) (loop_id (* Exception: end the corresponding borrows, and continue *) let cc = match e with - | LoanInRight bid -> InterpreterBorrows.end_borrow meta config bid - | LoansInRight bids -> InterpreterBorrows.end_borrows meta config bids + | LoanInRight bid -> InterpreterBorrows.end_borrow config meta bid + | LoansInRight bids -> InterpreterBorrows.end_borrows config meta bids | AbsInRight _ | AbsInLeft _ | LoanInLeft _ | LoansInLeft _ -> craise meta "Unexpected" in @@ -1837,7 +1837,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) BorrowId.Set.of_list (List.map snd (BorrowId.Map.bindings !src_fresh_borrows_map)) in - let cc = InterpreterBorrows.end_borrows meta config new_borrows in + let cc = InterpreterBorrows.end_borrows config meta new_borrows in (* Compute the loop input values *) let input_values = diff --git a/compiler/InterpreterLoopsMatchCtxs.mli b/compiler/InterpreterLoopsMatchCtxs.mli index 0db1ff1d..4a6d24a9 100644 --- a/compiler/InterpreterLoopsMatchCtxs.mli +++ b/compiler/InterpreterLoopsMatchCtxs.mli @@ -300,8 +300,8 @@ val prepare_match_ctx_with_target : - [src_ctx] *) val match_ctx_with_target : - Meta.meta -> config -> + Meta.meta -> loop_id -> bool -> borrow_loan_corresp -> diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index c7141064..6ec12d6f 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -445,7 +445,7 @@ let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind | Ok ctx -> ctx | Error _ -> craise meta "Unreachable" -let rec update_ctx_along_read_place (meta : Meta.meta) (config : config) (access : access_kind) +let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Attempt to read the place: if it fails, update the environment and retry *) @@ -454,9 +454,9 @@ let rec update_ctx_along_read_place (meta : Meta.meta) (config : config) (access | Error err -> let cc = match err with - | FailSharedLoan bids -> end_borrows meta config bids - | FailMutLoan bid -> end_borrow meta config bid - | FailReservedMutBorrow bid -> promote_reserved_mut_borrow meta config bid + | FailSharedLoan bids -> end_borrows config meta bids + | FailMutLoan bid -> end_borrow config meta bid + | FailReservedMutBorrow bid -> promote_reserved_mut_borrow config meta bid | FailSymbolic (i, sp) -> (* Expand the symbolic value *) let proj, _ = @@ -464,16 +464,16 @@ let rec update_ctx_along_read_place (meta : Meta.meta) (config : config) (access (List.length p.projection - i) in let prefix = { p with projection = proj } in - expand_symbolic_value_no_branching meta config sp + expand_symbolic_value_no_branching config meta sp (Some (Synth.mk_mplace meta prefix ctx)) | FailBottom (_, _, _) -> (* We can't expand {!Bottom} values while reading them *) craise meta "Found [Bottom] while reading a place" | FailBorrow _ -> craise meta "Could not read a borrow" in - comp cc (update_ctx_along_read_place meta config access p) cf ctx + comp cc (update_ctx_along_read_place config meta access p) cf ctx -let rec update_ctx_along_write_place (meta : Meta.meta) (config : config) (access : access_kind) +let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Attempt to *read* (yes, *read*: we check the access to the place, and @@ -484,12 +484,12 @@ let rec update_ctx_along_write_place (meta : Meta.meta) (config : config) (acces (* Update the context *) let cc = match err with - | FailSharedLoan bids -> end_borrows meta config bids - | FailMutLoan bid -> end_borrow meta config bid - | FailReservedMutBorrow bid -> promote_reserved_mut_borrow meta config bid + | FailSharedLoan bids -> end_borrows config meta bids + | FailMutLoan bid -> end_borrow config meta bid + | FailReservedMutBorrow bid -> promote_reserved_mut_borrow config meta bid | FailSymbolic (_pe, sp) -> (* Expand the symbolic value *) - expand_symbolic_value_no_branching meta config sp + expand_symbolic_value_no_branching config meta sp (Some (Synth.mk_mplace meta p ctx)) | FailBottom (remaining_pes, pe, ty) -> (* Expand the {!Bottom} value *) @@ -502,12 +502,12 @@ let rec update_ctx_along_write_place (meta : Meta.meta) (config : config) (acces | FailBorrow _ -> craise meta "Could not write to a borrow" in (* Retry *) - comp cc (update_ctx_along_write_place meta config access p) cf ctx + comp cc (update_ctx_along_write_place config meta access p) cf ctx (** Small utility used to break control-flow *) exception UpdateCtx of cm_fun -let rec end_loans_at_place (meta : Meta.meta) (config : config) (access : access_kind) (p : place) +let rec end_loans_at_place (config : config) (meta : Meta.meta) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Iterator to explore a value and update the context whenever we find @@ -525,7 +525,7 @@ let rec end_loans_at_place (meta : Meta.meta) (config : config) (access : access (* Nothing special to do *) super#visit_borrow_content env bc | VReservedMutBorrow bid -> (* We need to activate reserved borrows *) - let cc = promote_reserved_mut_borrow meta config bid in + let cc = promote_reserved_mut_borrow config meta bid in raise (UpdateCtx cc) method! visit_loan_content env lc = @@ -536,11 +536,11 @@ let rec end_loans_at_place (meta : Meta.meta) (config : config) (access : access match access with | Read -> super#visit_VSharedLoan env bids v | Write | Move -> - let cc = end_borrows meta config bids in + let cc = end_borrows config meta bids in raise (UpdateCtx cc)) | VMutLoan bid -> (* We always need to end mutable borrows *) - let cc = end_borrow meta config bid in + let cc = end_borrow config meta bid in raise (UpdateCtx cc) end in @@ -560,9 +560,9 @@ let rec end_loans_at_place (meta : Meta.meta) (config : config) (access : access with UpdateCtx cc -> (* We need to update the context: compose the caugth continuation with * a recursive call to reinspect the value *) - comp cc (end_loans_at_place meta config access p) cf ctx + comp cc (end_loans_at_place config meta access p) cf ctx -let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) : cm_fun = +let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) : cm_fun = fun cf ctx -> (* Move the current value in the place outside of this place and into * a dummy variable *) @@ -586,8 +586,8 @@ let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) (* There are: end them then retry *) let cc = match c with - | LoanContent (VSharedLoan (bids, _)) -> end_borrows meta config bids - | LoanContent (VMutLoan bid) -> end_borrow meta config bid + | LoanContent (VSharedLoan (bids, _)) -> end_borrows config meta bids + | LoanContent (VMutLoan bid) -> end_borrow config meta bid | BorrowContent _ -> craise meta "Unreachable" in (* Retry *) @@ -610,7 +610,7 @@ let drop_outer_loans_at_lplace (meta : Meta.meta) (config : config) (p : place) (* Continue *) cc cf ctx -let prepare_lplace (meta : Meta.meta) (config : config) (p : place) (cf : typed_value -> m_fun) : +let prepare_lplace (config : config) (meta : Meta.meta) (p : place) (cf : typed_value -> m_fun) : m_fun = fun ctx -> log#ldebug @@ -619,9 +619,9 @@ let prepare_lplace (meta : Meta.meta) (config : config) (p : place) (cf : typed_ ^ "\n- Initial context:\n" ^ eval_ctx_to_string meta ctx)); (* Access the place *) let access = Write in - let cc = update_ctx_along_write_place meta config access p in + let cc = update_ctx_along_write_place config meta access p in (* End the borrows and loans, starting with the borrows *) - let cc = comp cc (drop_outer_loans_at_lplace meta config p) in + let cc = comp cc (drop_outer_loans_at_lplace config meta p) in (* Read the value and check it *) let read_check cf : m_fun = fun ctx -> diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index faa68688..f1c481ca 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -13,13 +13,13 @@ type access_kind = Read | Write | Move updates the environment (by ending borrows, expanding symbolic values, etc.) until it manages to fully access the provided place. *) -val update_ctx_along_read_place : Meta.meta -> config -> access_kind -> place -> cm_fun +val update_ctx_along_read_place : config -> Meta.meta -> access_kind -> place -> cm_fun (** Update the environment to be able to write to a place. See {!update_ctx_along_read_place}. *) -val update_ctx_along_write_place : Meta.meta -> config -> access_kind -> place -> cm_fun +val update_ctx_along_write_place : config -> Meta.meta -> access_kind -> place -> cm_fun (** Read the value at a given place. @@ -74,7 +74,7 @@ val compute_expanded_bottom_adt_value : that the place is *inside* a borrow, if we end the borrow, we won't be able to reinsert the value back). *) -val drop_outer_loans_at_lplace : Meta.meta -> config -> place -> cm_fun +val drop_outer_loans_at_lplace : config -> Meta.meta -> place -> cm_fun (** End the loans at a given place: read the value, if it contains a loan, end this loan, repeat. @@ -85,7 +85,7 @@ val drop_outer_loans_at_lplace : Meta.meta -> config -> place -> cm_fun when moving values, we can't move a value which contains loans and thus need to end them, etc. *) -val end_loans_at_place : Meta.meta -> config -> access_kind -> place -> cm_fun +val end_loans_at_place : config -> Meta.meta -> access_kind -> place -> cm_fun (** Small utility. @@ -96,4 +96,4 @@ val end_loans_at_place : Meta.meta -> config -> access_kind -> place -> cm_fun place. This value should not contain any outer loan (and we check it is the case). Note that this value is very likely to contain ⊥ subvalues. *) -val prepare_lplace : Meta.meta -> config -> place -> (typed_value -> m_fun) -> m_fun +val prepare_lplace : config -> Meta.meta -> place -> (typed_value -> m_fun) -> m_fun diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index fff23aec..7eaa7659 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -468,7 +468,7 @@ let apply_reborrows (meta : Meta.meta) (reborrows : (BorrowId.id * BorrowId.id) (* Return *) ctx -let prepare_reborrows (meta : Meta.meta) (config : config) (allow_reborrows : bool) : +let prepare_reborrows (config : config) (meta : Meta.meta) (allow_reborrows : bool) : (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) = let reborrows : (BorrowId.id * BorrowId.id) list ref = ref [] in (* The function to generate and register fresh reborrows *) @@ -492,7 +492,7 @@ let prepare_reborrows (meta : Meta.meta) (config : config) (allow_reborrows : bo (fresh_reborrow, apply_registered_reborrows) (** [ty] shouldn't have erased regions *) -let apply_proj_borrows_on_input_value (meta : Meta.meta) (config : config) (ctx : eval_ctx) +let apply_proj_borrows_on_input_value (config : config) (meta : Meta.meta) (ctx : eval_ctx) (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = cassert (ty_is_rty ty) meta "TODO: error message"; @@ -500,7 +500,7 @@ let apply_proj_borrows_on_input_value (meta : Meta.meta) (config : config) (ctx let allow_reborrows = true in (* Prepare the reborrows *) let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows meta config allow_reborrows + prepare_reborrows config meta allow_reborrows in (* Apply the projector *) let av = diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index 7ffe4917..64ad1b29 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -43,7 +43,7 @@ val symbolic_expansion_non_shared_borrow_to_value : - [allow_reborrows] *) val prepare_reborrows : - Meta.meta -> config -> bool -> (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) + config -> Meta.meta -> bool -> (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) (** Apply (and reduce) a projector over borrows to an avalue. We use this for instance to spread the borrows present in the inputs @@ -116,8 +116,8 @@ val apply_proj_borrows : erased regions) *) val apply_proj_borrows_on_input_value : - Meta.meta -> config -> + Meta.meta -> eval_ctx -> RegionId.Set.t -> RegionId.Set.t -> diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index b71daac5..253d90cc 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -19,7 +19,7 @@ module S = SynthesizeSymbolic let log = L.statements_log (** Drop a value at a given place - TODO: factorize this with [assign_to_place] *) -let drop_value (meta : Meta.meta) (config : config) (p : place) : cm_fun = +let drop_value (config : config) (meta : Meta.meta) (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -29,9 +29,9 @@ let drop_value (meta : Meta.meta) (config : config) (p : place) : cm_fun = let access = Write in (* First make sure we can access the place, by ending loans or expanding * symbolic values along the path, for instance *) - let cc = update_ctx_along_read_place meta config access p in + let cc = update_ctx_along_read_place config meta access p in (* Prepare the place (by ending the outer loans *at* the place). *) - let cc = comp cc (prepare_lplace meta config p) in + let cc = comp cc (prepare_lplace config meta p) in (* Replace the value with {!Bottom} *) let replace cf (v : typed_value) ctx = (* Move the value at destination (that we will overwrite) to a dummy variable @@ -94,7 +94,7 @@ let push_vars (meta : Meta.meta) (vars : (var * typed_value) list) : cm_fun = dummy variable and putting in its destination (after having checked that preparing the destination didn't introduce ⊥). *) -let assign_to_place (meta : Meta.meta) (config : config) (rv : typed_value) (p : place) : cm_fun = +let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -106,7 +106,7 @@ let assign_to_place (meta : Meta.meta) (config : config) (rv : typed_value) (p : let rvalue_vid = fresh_dummy_var_id () in let cc = push_dummy_var rvalue_vid rv in (* Prepare the destination *) - let cc = comp cc (prepare_lplace meta config p) in + let cc = comp cc (prepare_lplace config meta p) in (* Retrieve the rvalue from the dummy variable *) let cc = comp cc (fun cf _lv -> remove_dummy_var meta rvalue_vid cf) in (* Update the destination *) @@ -136,11 +136,11 @@ let assign_to_place (meta : Meta.meta) (config : config) (rv : typed_value) (p : comp cc move_dest cf ctx (** Evaluate an assertion, when the scrutinee is not symbolic *) -let eval_assertion_concrete (meta : Meta.meta) (config : config) (assertion : assertion) : +let eval_assertion_concrete (config : config) (meta : Meta.meta) (assertion : assertion) : st_cm_fun = fun cf ctx -> (* There won't be any symbolic expansions: fully evaluate the operand *) - let eval_op = eval_operand meta config assertion.cond in + let eval_op = eval_operand config meta assertion.cond in let eval_assert cf (v : typed_value) : m_fun = fun ctx -> match v.value with @@ -160,10 +160,10 @@ let eval_assertion_concrete (meta : Meta.meta) (config : config) (assertion : as a call to [assert ...] then continue in the success branch (and thus expand the boolean to [true]). *) -let eval_assertion (meta : Meta.meta) (config : config) (assertion : assertion) : st_cm_fun = +let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) : st_cm_fun = fun cf ctx -> (* Evaluate the operand *) - let eval_op = eval_operand meta config assertion.cond in + let eval_op = eval_operand config meta assertion.cond in (* Evaluate the assertion *) let eval_assert cf (v : typed_value) : m_fun = fun ctx -> @@ -176,7 +176,7 @@ let eval_assertion (meta : Meta.meta) (config : config) (assertion : assertion) match v.value with | VLiteral (VBool _) -> (* Delegate to the concrete evaluation function *) - eval_assertion_concrete meta config assertion cf ctx + eval_assertion_concrete config meta assertion cf ctx | VSymbolic sv -> cassert (config.mode = SymbolicMode) meta "TODO: Error message"; cassert (sv.sv_ty = TLiteral TBool) meta "TODO: Error message"; @@ -185,7 +185,7 @@ let eval_assertion (meta : Meta.meta) (config : config) (assertion : assertion) * We will of course synthesize an assertion in the generated code * (see below). *) let ctx = - apply_symbolic_expansion_non_borrow meta config sv (SeLiteral (VBool true)) + apply_symbolic_expansion_non_borrow config meta sv (SeLiteral (VBool true)) ctx in (* Continue *) @@ -210,7 +210,7 @@ let eval_assertion (meta : Meta.meta) (config : config) (assertion : assertion) a variant with all its fields set to {!Bottom}. For instance, something like: [Cons Bottom Bottom]. *) -let set_discriminant (meta : Meta.meta) (config : config) (p : place) (variant_id : VariantId.id) : +let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_id : VariantId.id) : st_cm_fun = fun cf ctx -> log#ldebug @@ -221,8 +221,8 @@ let set_discriminant (meta : Meta.meta) (config : config) (p : place) (variant_i ^ "\n- initial context:\n" ^ eval_ctx_to_string meta ctx)); (* Access the value *) let access = Write in - let cc = update_ctx_along_read_place meta config access p in - let cc = comp cc (prepare_lplace meta config p) in + let cc = update_ctx_along_read_place config meta access p in + let cc = comp cc (prepare_lplace config meta p) in (* Update the value *) let update_value cf (v : typed_value) : m_fun = fun ctx -> @@ -248,7 +248,7 @@ let set_discriminant (meta : Meta.meta) (config : config) (p : place) (variant_i (Some variant_id) generics | _ -> craise meta "Unreachable" in - assign_to_place meta config bottom_v p (cf Unit) ctx) + assign_to_place config meta bottom_v p (cf Unit) ctx) | TAdt ((TAdtId _ as type_id), generics), VBottom -> let bottom_v = match type_id with @@ -257,7 +257,7 @@ let set_discriminant (meta : Meta.meta) (config : config) (p : place) (variant_i generics | _ -> craise meta "Unreachable" in - assign_to_place meta config bottom_v p (cf Unit) ctx + assign_to_place config meta bottom_v p (cf Unit) ctx | _, VSymbolic _ -> cassert (config.mode = SymbolicMode) meta "The Config mode should be SymbolicMode"; (* This is a bit annoying: in theory we should expand the symbolic value @@ -316,11 +316,11 @@ let move_return_value (config : config) (meta : Meta.meta) (pop_return_value : b fun ctx -> if pop_return_value then let ret_vid = VarId.zero in - let cc = eval_operand meta config (Move (mk_place_from_var_id ret_vid)) in + let cc = eval_operand config meta (Move (mk_place_from_var_id ret_vid)) in cc (fun v ctx -> cf (Some v) ctx) ctx else cf None ctx -let pop_frame (meta : Meta.meta) (config : config) (pop_return_value : bool) +let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) (cf : typed_value option -> m_fun) : m_fun = fun ctx -> (* Debug *) @@ -364,7 +364,7 @@ let pop_frame (meta : Meta.meta) (config : config) (pop_return_value : bool) let cf_drop = List.fold_left (fun cf lid -> - drop_outer_loans_at_lplace meta config (mk_place_from_var_id lid) cf) + drop_outer_loans_at_lplace config meta (mk_place_from_var_id lid) cf) (cf ret_value) locals in (* Apply *) @@ -402,15 +402,15 @@ let pop_frame (meta : Meta.meta) (config : config) (pop_return_value : bool) comp cc cf_pop cf ctx (** Pop the current frame and assign the returned value to its destination. *) -let pop_frame_assign (meta : Meta.meta) (config : config) (dest : place) : cm_fun = - let cf_pop = pop_frame meta config true in +let pop_frame_assign (config : config) (meta : Meta.meta) (dest : place) : cm_fun = + let cf_pop = pop_frame config meta true in let cf_assign cf ret_value : m_fun = - assign_to_place meta config (Option.get ret_value) dest cf + assign_to_place config meta (Option.get ret_value) dest cf in comp cf_pop cf_assign (** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_new_concrete (meta : Meta.meta) (config : config) (generics : generic_args) : cm_fun = +let eval_box_new_concrete (config : config) (meta : Meta.meta) (generics : generic_args) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) match @@ -427,7 +427,7 @@ let eval_box_new_concrete (meta : Meta.meta) (config : config) (generics : gener (* Move the input value *) let cf_move = - eval_operand meta config (Move (mk_place_from_var_id input_var.index)) + eval_operand config meta (Move (mk_place_from_var_id input_var.index)) in (* Create the new box *) @@ -442,7 +442,7 @@ let eval_box_new_concrete (meta : Meta.meta) (config : config) (generics : gener (* Move this value to the return variable *) let dest = mk_place_from_var_id VarId.zero in - let cf_assign = assign_to_place meta config box_v dest in + let cf_assign = assign_to_place config meta box_v dest in (* Continue *) cf_assign cf @@ -471,7 +471,7 @@ let eval_box_new_concrete (meta : Meta.meta) (config : config) (generics : gener It thus updates the box value (by calling {!drop_value}) and updates the destination (by setting it to [()]). *) -let eval_box_free (meta : Meta.meta) (config : config) (generics : generic_args) +let eval_box_free (config : config) (meta : Meta.meta) (generics : generic_args) (args : operand list) (dest : place) : cm_fun = fun cf ctx -> match (generics.regions, generics.types, generics.const_generics, args) with @@ -482,17 +482,17 @@ let eval_box_free (meta : Meta.meta) (config : config) (generics : generic_args) cassert (input_ty = boxed_ty)) meta "TODO: Error message"; (* Drop the value *) - let cc = drop_value meta config input_box_place in + let cc = drop_value config meta input_box_place in (* Update the destination by setting it to [()] *) - let cc = comp cc (assign_to_place meta config mk_unit_value dest) in + let cc = comp cc (assign_to_place config meta mk_unit_value dest) in (* Continue *) cc cf ctx | _ -> craise meta "Inconsistent state" (** Evaluate a non-local function call in concrete mode *) -let eval_assumed_function_call_concrete (meta : Meta.meta) (config : config) (fid : assumed_fun_id) +let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) (fid : assumed_fun_id) (call : call) : cm_fun = let args = call.args in let dest = call.dest in @@ -514,12 +514,12 @@ let eval_assumed_function_call_concrete (meta : Meta.meta) (config : config) (fi match fid with | BoxFree -> (* Degenerate case: box_free *) - eval_box_free meta config generics args dest + eval_box_free config meta generics args dest | _ -> (* "Normal" case: not box_free *) (* Evaluate the operands *) (* let ctx, args_vl = eval_operands config ctx args in *) - let cf_eval_ops = eval_operands meta config args in + let cf_eval_ops = eval_operands config meta args in (* Evaluate the call * @@ -553,7 +553,7 @@ let eval_assumed_function_call_concrete (meta : Meta.meta) (config : config) (fi * access to a body. *) let cf_eval_body : cm_fun = match fid with - | BoxNew -> eval_box_new_concrete meta config generics + | BoxNew -> eval_box_new_concrete config meta generics | BoxFree -> (* Should have been treated above *) craise meta "Unreachable" @@ -566,7 +566,7 @@ let eval_assumed_function_call_concrete (meta : Meta.meta) (config : config) (fi let cc = comp cc cf_eval_body in (* Pop the frame *) - let cc = comp cc (pop_frame_assign meta config dest) in + let cc = comp cc (pop_frame_assign config meta dest) in (* Continue *) cc cf ctx @@ -937,7 +937,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = let cc = S.cf_save_snapshot in (* Expand the symbolic values if necessary - we need to do that before * checking the invariants *) - let cc = comp cc (greedy_expand_symbolic_values st.meta config) in + let cc = comp cc (greedy_expand_symbolic_values config st.meta) in (* Sanity check *) let cc = comp cc (Invariants.cf_check_invariants st.meta) in @@ -958,7 +958,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = eval_global config p gid generics cf ctx | _ -> (* Evaluate the rvalue *) - let cf_eval_rvalue = eval_rvalue_not_global st.meta config rvalue in + let cf_eval_rvalue = eval_rvalue_not_global config st.meta rvalue in (* Assign *) let cf_assign cf (res : (typed_value, eval_error) result) ctx = log#ldebug @@ -968,7 +968,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = match res with | Error EPanic -> cf Panic ctx | Ok rv -> ( - let expr = assign_to_place st.meta config rv p (cf Unit) ctx in + let expr = assign_to_place config st.meta rv p (cf Unit) ctx in (* Update the synthesized AST - here we store meta-information. * We do it only in specific cases (it is not always useful, and * also it can lead to issues - for instance, if we borrow a @@ -990,12 +990,12 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = (* Compose and apply *) comp cf_eval_rvalue cf_assign cf ctx) - | FakeRead p -> eval_fake_read st.meta config p (cf Unit) ctx + | FakeRead p -> eval_fake_read config st.meta p (cf Unit) ctx | SetDiscriminant (p, variant_id) -> - set_discriminant st.meta config p variant_id cf ctx - | Drop p -> drop_value st.meta config p (cf Unit) ctx - | Assert assertion -> eval_assertion st.meta config assertion cf ctx - | Call call -> eval_function_call st.meta config call cf ctx + set_discriminant config st.meta p variant_id cf ctx + | Drop p -> drop_value config st.meta p (cf Unit) ctx + | Assert assertion -> eval_assertion config st.meta assertion cf ctx + | Call call -> eval_function_call config st.meta call cf ctx | Panic -> cf Panic ctx | Return -> cf Return ctx | Break i -> cf (Break i) ctx @@ -1020,7 +1020,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = InterpreterLoops.eval_loop config st.meta (eval_statement config loop_body) cf ctx - | Switch switch -> eval_switch st.meta config switch cf ctx + | Switch switch -> eval_switch config st.meta switch cf ctx in (* Compose and apply *) comp cc cf_eval_st cf ctx @@ -1034,7 +1034,7 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) (* Treat the evaluation of the global as a call to the global body *) let func = { func = FunId (FRegular global.body); generics } in let call = { func = FnOpRegular func; args = []; dest } in - (eval_transparent_function_call_concrete global.meta config global.body call) cf ctx + (eval_transparent_function_call_concrete config global.meta global.body call) cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) @@ -1052,13 +1052,13 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) in let sval = mk_fresh_symbolic_value ty in let cc = - assign_to_place global.meta config (mk_typed_value_from_symbolic_value sval) dest + assign_to_place config global.meta (mk_typed_value_from_symbolic_value sval) dest in let e = cc (cf Unit) ctx in S.synthesize_global_eval gid generics sval e (** Evaluate a switch *) -and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_fun = +and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_fun = fun cf ctx -> (* We evaluate the operand in two steps: * first we prepare it, then we check if its value is concrete or @@ -1074,7 +1074,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f match switch with | If (op, st1, st2) -> (* Evaluate the operand *) - let cf_eval_op = eval_operand meta config op in + let cf_eval_op = eval_operand config meta op in (* Switch on the value *) let cf_if (cf : st_m_fun) (op_v : typed_value) : m_fun = fun ctx -> @@ -1093,7 +1093,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f * the branches *) let cf_true : st_cm_fun = eval_statement config st1 in let cf_false : st_cm_fun = eval_statement config st2 in - expand_symbolic_bool meta config sv + expand_symbolic_bool config meta sv (S.mk_opt_place_from_op meta op ctx) cf_true cf_false cf ctx | _ -> craise meta "Inconsistent state" @@ -1102,7 +1102,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f comp cf_eval_op cf_if cf ctx | SwitchInt (op, int_ty, stgts, otherwise) -> (* Evaluate the operand *) - let cf_eval_op = eval_operand meta config op in + let cf_eval_op = eval_operand config meta op in (* Switch on the value *) let cf_switch (cf : st_m_fun) (op_v : typed_value) : m_fun = fun ctx -> @@ -1140,7 +1140,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f (* Translate the otherwise branch *) let otherwise = eval_statement config otherwise in (* Expand and continue *) - expand_symbolic_int meta config sv + expand_symbolic_int config meta sv (S.mk_opt_place_from_op meta op ctx) int_ty stgts otherwise cf ctx | _ -> craise meta "Inconsistent state" @@ -1152,7 +1152,7 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f let access = Read in let expand_prim_copy = false in let cf_read_p cf : m_fun = - access_rplace_reorganize_and_read meta config expand_prim_copy access p cf + access_rplace_reorganize_and_read config meta expand_prim_copy access p cf in (* Match on the value *) let cf_match (cf : st_m_fun) (p_v : typed_value) : m_fun = @@ -1175,11 +1175,11 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f | VSymbolic sv -> (* Expand the symbolic value - may lead to branching *) let cf_expand = - expand_symbolic_adt meta config sv (Some (S.mk_mplace meta p ctx)) + expand_symbolic_adt config meta sv (Some (S.mk_mplace meta p ctx)) in (* Re-evaluate the switch - the value is not symbolic anymore, which means we will go to the other branch *) - cf_expand (eval_switch meta config switch) cf ctx + cf_expand (eval_switch config meta switch) cf ctx | _ -> craise meta "Inconsistent state" in (* Compose *) @@ -1189,44 +1189,44 @@ and eval_switch (meta : Meta.meta) (config : config) (switch : switch) : st_cm_f cf_match cf ctx (** Evaluate a function call (auxiliary helper for [eval_statement]) *) -and eval_function_call (meta : Meta.meta) (config : config) (call : call) : st_cm_fun = +and eval_function_call (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = (* There are several cases: - this is a local function, in which case we execute its body - this is an assumed function, in which case there is a special treatment - this is a trait method *) match config.mode with - | ConcreteMode -> eval_function_call_concrete meta config call - | SymbolicMode -> eval_function_call_symbolic meta config call + | ConcreteMode -> eval_function_call_concrete config meta call + | SymbolicMode -> eval_function_call_symbolic config meta call -and eval_function_call_concrete (meta : Meta.meta) (config : config) (call : call) : st_cm_fun = +and eval_function_call_concrete (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = fun cf ctx -> match call.func with | FnOpMove _ -> craise meta "Closures are not supported yet" | FnOpRegular func -> ( match func.func with | FunId (FRegular fid) -> - eval_transparent_function_call_concrete meta config fid call cf ctx + eval_transparent_function_call_concrete config meta fid call cf ctx | FunId (FAssumed fid) -> (* Continue - note that we do as if the function call has been successful, * by giving {!Unit} to the continuation, because we place us in the case * where we haven't panicked. Of course, the translation needs to take the * panic case into account... *) - eval_assumed_function_call_concrete meta config fid call (cf Unit) ctx + eval_assumed_function_call_concrete config meta fid call (cf Unit) ctx | TraitMethod _ -> craise meta "Unimplemented") -and eval_function_call_symbolic (meta : Meta.meta) (config : config) (call : call) : st_cm_fun = +and eval_function_call_symbolic (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = match call.func with | FnOpMove _ -> craise meta "Closures are not supported yet" | FnOpRegular func -> ( match func.func with | FunId (FRegular _) | TraitMethod _ -> - eval_transparent_function_call_symbolic meta config call + eval_transparent_function_call_symbolic config meta call | FunId (FAssumed fid) -> - eval_assumed_function_call_symbolic meta config fid call func) + eval_assumed_function_call_symbolic config meta fid call func) (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) +and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) (fid : FunDeclId.id) (call : call) : st_cm_fun = let args = call.args in let dest = call.dest in @@ -1261,7 +1261,7 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) (* Evaluate the input operands *) cassert (List.length args = body.arg_count) body.meta "TODO: Error message"; - let cc = eval_operands body.meta config args in + let cc = eval_operands config body.meta args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result * of the operands evaluation from above to the functions afterwards, while @@ -1296,7 +1296,7 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) let cc = comp cc (push_uninitialized_vars meta locals) in (* Execute the function body *) - let cc = comp cc (eval_function_body meta config body_st) in + let cc = comp cc (eval_function_body config meta body_st) in (* Pop the stack frame and move the return value to its destination *) let cf_finish cf res = @@ -1305,7 +1305,7 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) | Return -> (* Pop the stack frame, retrieve the return value, move it to * its destination and continue *) - pop_frame_assign meta config dest (cf Unit) + pop_frame_assign config meta dest (cf Unit) | Break _ | Continue _ | Unit | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> craise meta "Unreachable" @@ -1316,7 +1316,7 @@ and eval_transparent_function_call_concrete (meta : Meta.meta) (config : config) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_transparent_function_call_symbolic (meta : Meta.meta) (config : config) (call : call) : +and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = fun cf ctx -> let func, generics, trait_method_generics, def, regions_hierarchy, inst_sg = @@ -1325,7 +1325,7 @@ and eval_transparent_function_call_symbolic (meta : Meta.meta) (config : config) (* Sanity check *) cassert (List.length call.args = List.length def.signature.inputs) def.meta "TODO: Error message"; (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig def.meta config func def.signature + eval_function_call_symbolic_from_inst_sig config def.meta func def.signature regions_hierarchy inst_sg generics trait_method_generics call.args call.dest cf ctx @@ -1340,7 +1340,7 @@ and eval_transparent_function_call_symbolic (meta : Meta.meta) (config : config) overriding them. We treat them as regular method, which take an additional trait ref as input. *) -and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : config) +and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.meta) (fid : fun_id_or_trait_method_ref) (sg : fun_sig) (regions_hierarchy : region_var_groups) (inst_sg : inst_fun_sig) (generics : generic_args) @@ -1370,7 +1370,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi let dest_place = Some (S.mk_mplace meta dest ctx) in (* Evaluate the input operands *) - let cc = eval_operands meta config args in + let cc = eval_operands config meta args in (* Generate the abstractions and insert them in the context *) let abs_ids = List.map (fun rg -> rg.id) inst_sg.regions_hierarchy in @@ -1404,7 +1404,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi let ctx, args_projs = List.fold_left_map (fun ctx (arg, arg_rty) -> - apply_proj_borrows_on_input_value meta config ctx abs.regions + apply_proj_borrows_on_input_value config meta ctx abs.regions abs.ancestors_regions arg arg_rty) ctx args_with_rtypes in @@ -1431,7 +1431,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi let cc = comp cc cf_call in (* Move the return value to its destination *) - let cc = comp cc (assign_to_place meta config ret_value dest) in + let cc = comp cc (assign_to_place config meta ret_value dest) in (* End the abstractions which don't contain loans and don't have parent * abstractions. @@ -1461,7 +1461,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi abs_ids := with_loans_abs; (* End the abstractions which can be ended *) let no_loans_abs = AbstractionId.Set.of_list no_loans_abs in - let cc = InterpreterBorrows.end_abstractions meta config no_loans_abs in + let cc = InterpreterBorrows.end_abstractions config meta no_loans_abs in (* Recursive call *) let cc = comp cc end_abs_with_no_loans in (* Continue *) @@ -1487,7 +1487,7 @@ and eval_function_call_symbolic_from_inst_sig (meta : Meta.meta) (config : confi cc (cf Unit) ctx (** Evaluate a non-local function call in symbolic mode *) -and eval_assumed_function_call_symbolic (meta : Meta.meta) (config : config) (fid : assumed_fun_id) +and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) (fid : assumed_fun_id) (call : call) (func : fn_ptr) : st_cm_fun = fun cf ctx -> let generics = func.generics in @@ -1509,7 +1509,7 @@ and eval_assumed_function_call_symbolic (meta : Meta.meta) (config : config) (fi | BoxFree -> (* Degenerate case: box_free - note that this is not really a function * call: no need to call a "synthesize_..." function *) - eval_box_free meta config generics args dest (cf Unit) ctx + eval_box_free config meta generics args dest (cf Unit) ctx | _ -> (* "Normal" case: not box_free *) (* In symbolic mode, the behaviour of a function call is completely defined @@ -1535,11 +1535,11 @@ and eval_assumed_function_call_symbolic (meta : Meta.meta) (config : config) (fi in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig meta config (FunId (FAssumed fid)) sg + eval_function_call_symbolic_from_inst_sig config meta (FunId (FAssumed fid)) sg regions_hierarchy inst_sig generics None args dest cf ctx (** Evaluate a statement seen as a function body *) -and eval_function_body (meta : Meta.meta) (config : config) (body : statement) : st_cm_fun = +and eval_function_body (config : config) (meta : Meta.meta) (body : statement) : st_cm_fun = fun cf ctx -> log#ldebug (lazy "eval_function_body:"); let cc = eval_statement config body in @@ -1549,7 +1549,7 @@ and eval_function_body (meta : Meta.meta) (config : config) (body : statement) : * delegate the check to the caller. *) (* Expand the symbolic values if necessary - we need to do that before * checking the invariants *) - let cc = greedy_expand_symbolic_values body.meta config in + let cc = greedy_expand_symbolic_values config body.meta in (* Sanity check *) let cc = comp_check_ctx cc (Invariants.check_invariants meta) in (* Check if right meta *) (* Continue *) diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index 3b1285a6..519d2c8e 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -16,7 +16,7 @@ open Cps If the boolean is false, we don't move the return value, and call the continuation with [None]. *) -val pop_frame : Meta.meta -> config -> bool -> (typed_value option -> m_fun) -> m_fun +val pop_frame : config -> Meta.meta -> bool -> (typed_value option -> m_fun) -> m_fun (** Helper. @@ -48,4 +48,4 @@ val create_push_abstractions_from_abs_region_groups : val eval_statement : config -> statement -> st_cm_fun (** Evaluate a statement seen as a function body *) -val eval_function_body : Meta.meta -> config -> statement -> st_cm_fun +val eval_function_body : config -> Meta.meta -> statement -> st_cm_fun -- cgit v1.2.3 From 7a304e990d80dc052f63f66401544040fa0f2728 Mon Sep 17 00:00:00 2001 From: Escherichia Date: Tue, 26 Mar 2024 12:14:32 +0100 Subject: added a meta option field to norm_ctx and changed the meta used by some assert to the norm_ctx one --- compiler/AssociatedTypes.ml | 57 ++++++++++++++++++-------------------- compiler/ExtractBase.ml | 1 - compiler/Interpreter.ml | 6 ++-- compiler/InterpreterExpressions.ml | 2 +- compiler/InterpreterStatements.ml | 2 +- compiler/InterpreterUtils.ml | 2 +- compiler/RegionsHierarchy.ml | 1 + compiler/SymbolicToPure.ml | 2 +- 8 files changed, 35 insertions(+), 38 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index cce5a082..38615777 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -102,6 +102,7 @@ let rec trait_instance_id_is_local_clause (id : trait_instance_id) : bool = but they should be applied to types without regions. *) type norm_ctx = { + meta : Meta.meta option; norm_trait_types : ty TraitTypeRefMap.t; type_decls : type_decl TypeDeclId.Map.t; fun_decls : fun_decl FunDeclId.Map.t; @@ -238,8 +239,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = match trait_ref.trait_id with | TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ } -> - let meta = (TraitImplId.Map.find impl_id ctx.trait_impls).meta in - cassert (ref_generics = empty_generic_args) meta "Higher order types are not supported yet TODO: error message"; + cassert_opt_meta (ref_generics = empty_generic_args) ctx.meta "Higher order types are not supported yet TODO: error message"; log#ldebug (lazy ("norm_ctx_normalize_ty: trait type: trait ref: " @@ -279,8 +279,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* We can't project *) - let meta = (TraitDeclId.Map.find trait_ref.trait_decl_ref.trait_decl_id ctx.trait_decls).meta in - cassert (trait_instance_id_is_local_clause trait_ref.trait_id) meta "TODO: error message"; + cassert_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta "TODO: error message"; TTraitType (trait_ref, type_name) in let tr : trait_type_ref = { trait_ref; type_name } in @@ -345,11 +344,10 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | ParentClause (inst_id, decl_id, clause_id) -> ( let inst_id, impl = norm_ctx_normalize_trait_instance_id ctx inst_id in (* Check if the inst_id refers to a specific implementation, if yes project *) - let meta = (TraitDeclId.Map.find decl_id ctx.trait_decls).meta in match impl with | None -> (* This is actually a local clause *) - cassert (trait_instance_id_is_local_clause inst_id) meta "TODO: error message"; + cassert_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta "TODO: error message"; (ParentClause (inst_id, decl_id, clause_id), None) | Some impl -> (* We figure out the parent clause by doing the following: @@ -375,13 +373,12 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) let clause = norm_ctx_normalize_trait_ref ctx clause in (TraitRef clause, Some clause)) | ItemClause (inst_id, decl_id, item_name, clause_id) -> ( - let meta = (TraitDeclId.Map.find decl_id ctx.trait_decls).meta in let inst_id, impl = norm_ctx_normalize_trait_instance_id ctx inst_id in (* Check if the inst_id refers to a specific implementation, if yes project *) match impl with | None -> (* This is actually a local clause *) - cassert (trait_instance_id_is_local_clause inst_id) meta "Trait instance id is not a local clause"; + cassert_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta "Trait instance id is not a local clause"; (ItemClause (inst_id, decl_id, item_name, clause_id), None) | Some impl -> (* We figure out the item clause by doing the following: @@ -421,9 +418,9 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) - let meta = (TraitDeclId.Map.find trait_ref.trait_decl_ref.trait_decl_id ctx.trait_decls).meta in - cassert (trait_instance_id_is_local_clause trait_ref.trait_id) meta "Trait instance id is not a local sub-clause"; - cassert (trait_ref.generics = empty_generic_args) meta "TODO: error message"; +(* let meta = (TraitDeclId.Map.find trait_ref.trait_decl_ref.trait_decl_id ctx.trait_decls).meta in *) + cassert_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta "Trait instance id is not a local sub-clause"; + cassert_opt_meta (trait_ref.generics = empty_generic_args) ctx.meta "TODO: error message"; (trait_ref.trait_id, None) | FnPointer ty -> let ty = norm_ctx_normalize_ty ctx ty in @@ -472,8 +469,7 @@ and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : trait_ref) : (lazy ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); - let meta = (TraitDeclId.Map.find trait_ref.trait_decl_ref.trait_decl_id ctx.trait_decls).meta in - cassert (generics = empty_generic_args) meta "TODO: error message"; + cassert_opt_meta (generics = empty_generic_args) ctx.meta "TODO: error message"; trait_ref (* Not sure this one is really necessary *) @@ -490,8 +486,9 @@ let norm_ctx_normalize_trait_type_constraint (ctx : norm_ctx) let ty = norm_ctx_normalize_ty ctx ty in { trait_ref; type_name; ty } -let mk_norm_ctx (ctx : eval_ctx) : norm_ctx = +let mk_norm_ctx (meta : Meta.meta) (ctx : eval_ctx) : norm_ctx = { + meta = Some meta; norm_trait_types = ctx.norm_trait_types; type_decls = ctx.type_ctx.type_decls; fun_decls = ctx.fun_ctx.fun_decls; @@ -502,17 +499,17 @@ let mk_norm_ctx (ctx : eval_ctx) : norm_ctx = const_generic_vars = ctx.const_generic_vars; } -let ctx_normalize_ty (ctx : eval_ctx) (ty : ty) : ty = - norm_ctx_normalize_ty (mk_norm_ctx ctx) ty +let ctx_normalize_ty (meta : Meta.meta) (ctx : eval_ctx) (ty : ty) : ty = + norm_ctx_normalize_ty (mk_norm_ctx meta ctx) ty (** Normalize a type and erase the regions at the same time *) -let ctx_normalize_erase_ty (ctx : eval_ctx) (ty : ty) : ty = - let ty = ctx_normalize_ty ctx ty in +let ctx_normalize_erase_ty (meta : Meta.meta) (ctx : eval_ctx) (ty : ty) : ty = + let ty = ctx_normalize_ty meta ctx ty in Subst.erase_regions ty -let ctx_normalize_trait_type_constraint (ctx : eval_ctx) +let ctx_normalize_trait_type_constraint (meta : Meta.meta) (ctx : eval_ctx) (ttc : trait_type_constraint) : trait_type_constraint = - norm_ctx_normalize_trait_type_constraint (mk_norm_ctx ctx) ttc + norm_ctx_normalize_trait_type_constraint (mk_norm_ctx meta ctx) ttc (** Same as [type_decl_get_instantiated_variants_fields_types] but normalizes the types *) let type_decl_get_inst_norm_variants_fields_rtypes (ctx : eval_ctx) @@ -523,7 +520,7 @@ let type_decl_get_inst_norm_variants_fields_rtypes (ctx : eval_ctx) in List.map (fun (variant_id, types) -> - (variant_id, List.map (ctx_normalize_ty ctx) types)) + (variant_id, List.map (ctx_normalize_ty def.meta ctx) types)) res (** Same as [type_decl_get_instantiated_field_types] but normalizes the types *) @@ -532,7 +529,7 @@ let type_decl_get_inst_norm_field_rtypes (ctx : eval_ctx) (def : type_decl) let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in - List.map (ctx_normalize_ty ctx) types + List.map (ctx_normalize_ty def.meta ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (adt : adt_value) @@ -540,7 +537,7 @@ let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) let types = Subst.ctx_adt_value_get_instantiated_field_types meta ctx adt id generics in - List.map (ctx_normalize_ty ctx) types + List.map (ctx_normalize_ty meta ctx) types (** Same as [ctx_adt_value_get_instantiated_field_types] but normalizes the types and erases the regions. *) @@ -549,22 +546,22 @@ let type_decl_get_inst_norm_field_etypes (ctx : eval_ctx) (def : type_decl) let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in - let types = List.map (ctx_normalize_ty ctx) types in + let types = List.map (ctx_normalize_ty def.meta ctx) types in List.map Subst.erase_regions types (** Same as [ctx_adt_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let ctx_adt_get_inst_norm_field_etypes (ctx : eval_ctx) (def_id : TypeDeclId.id) +let ctx_adt_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.ctx_adt_get_instantiated_field_types ctx def_id opt_variant_id generics in - let types = List.map (ctx_normalize_ty ctx) types in + let types = List.map (ctx_normalize_ty meta ctx) types in List.map Subst.erase_regions types (** Same as [substitute_signature] but normalizes the types *) -let ctx_subst_norm_signature (ctx : eval_ctx) +let ctx_subst_norm_signature (meta : Meta.meta) (ctx : eval_ctx) (asubst : RegionGroupId.id -> AbstractionId.id) (r_subst : RegionVarId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) (cg_subst : ConstGenericVarId.id -> const_generic) @@ -576,9 +573,9 @@ let ctx_subst_norm_signature (ctx : eval_ctx) sg regions_hierarchy in let { regions_hierarchy; inputs; output; trait_type_constraints } = sg in - let inputs = List.map (ctx_normalize_ty ctx) inputs in - let output = ctx_normalize_ty ctx output in + let inputs = List.map (ctx_normalize_ty meta ctx) inputs in + let output = ctx_normalize_ty meta ctx output in let trait_type_constraints = - List.map (ctx_normalize_trait_type_constraint ctx) trait_type_constraints + List.map (ctx_normalize_trait_type_constraint meta ctx) trait_type_constraints in { regions_hierarchy; inputs; output; trait_type_constraints } diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 71717b57..6e799bd9 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -748,7 +748,6 @@ let ctx_get_local_trait_clause (meta : Meta.meta) (id : TraitClauseId.id) (ctx : let ctx_get_field (meta : Meta.meta) (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = - (* let meta = (TypeDeclId.Map.find type_id ctx.trans_types).meta in TODO : check how to get meta *) ctx_get ~meta:(Some meta) (FieldId (type_id, field_id)) ctx let ctx_get_struct (meta : Meta.meta) (def_id : type_id) (ctx : extraction_ctx) : string = diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 6e2c15d7..2ac772ae 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -49,11 +49,11 @@ let compute_contexts (m : crate) : decls_ctx = to compute a normalization map (for the associated types) and that we added it in the context. *) -let normalize_inst_fun_sig (ctx : eval_ctx) (sg : inst_fun_sig) : inst_fun_sig = +let normalize_inst_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : inst_fun_sig) : inst_fun_sig = let { regions_hierarchy = _; trait_type_constraints = _; inputs; output } = sg in - let norm = AssociatedTypes.ctx_normalize_ty ctx in + let norm = AssociatedTypes.ctx_normalize_ty meta ctx in let inputs = List.map norm inputs in let output = norm output in { sg with inputs; output } @@ -157,7 +157,7 @@ let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : fun_s inst_sg.trait_type_constraints in (* Normalize the signature *) - let inst_sg = normalize_inst_fun_sig ctx inst_sg in + let inst_sg = normalize_inst_fun_sig meta ctx inst_sg in (* Return *) (ctx, inst_sg) diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index d74e0751..6c4f8af5 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -741,7 +741,7 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : List.length type_decl.generics.regions = List.length generics.regions) meta "TODO: error message"; let expected_field_types = - AssociatedTypes.ctx_adt_get_inst_norm_field_etypes ctx def_id + AssociatedTypes.ctx_adt_get_inst_norm_field_etypes meta ctx def_id opt_variant_id generics in cassert ( diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 253d90cc..0d0fd0a5 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -309,7 +309,7 @@ let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self sg.output in - AssociatedTypes.ctx_normalize_erase_ty ctx ty + AssociatedTypes.ctx_normalize_erase_ty meta ctx ty let move_return_value (config : config) (meta : Meta.meta) (pop_return_value : bool) (cf : typed_value option -> m_fun) : m_fun = diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 48869739..b5402bb0 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -514,7 +514,7 @@ let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (generics : generic_ in (* Substitute the signature *) let inst_sig = - AssociatedTypes.ctx_subst_norm_signature ctx asubst rsubst tsubst cgsubst + AssociatedTypes.ctx_subst_norm_signature meta ctx asubst rsubst tsubst cgsubst tr_subst tr_self sg regions_hierarchy in (* Return *) diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index 4ebdd01a..0672a25f 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -55,6 +55,7 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty sg.preds.trait_type_constraints in { + meta = meta; norm_trait_types; type_decls; fun_decls; diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 63605b9c..b62966bd 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -973,7 +973,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) (* Normalize the signature *) let sg = let ({ A.inputs; output; _ } : A.fun_sig) = sg in - let norm = AssociatedTypes.ctx_normalize_ty ctx in + let norm = AssociatedTypes.ctx_normalize_ty meta ctx in let inputs = List.map norm inputs in let output = norm output in { sg with A.inputs; output } -- cgit v1.2.3 From c47e349dedaaf0e3161869740ea769332ffd24ca Mon Sep 17 00:00:00 2001 From: Escherichia Date: Tue, 26 Mar 2024 17:00:47 +0100 Subject: changes to extract_ty and related functions to use the right meta --- compiler/AssociatedTypes.ml | 1 - compiler/Extract.ml | 58 ++++++++++++++++++++++----------------------- compiler/ExtractBase.ml | 29 +++++++++-------------- compiler/ExtractTypes.ml | 24 +++++++++---------- 4 files changed, 52 insertions(+), 60 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 38615777..0ed46e8c 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -418,7 +418,6 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) -(* let meta = (TraitDeclId.Map.find trait_ref.trait_decl_ref.trait_decl_id ctx.trait_decls).meta in *) cassert_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta "Trait instance id is not a local sub-clause"; cassert_opt_meta (trait_ref.generics = empty_generic_args) ctx.meta "TODO: error message"; (trait_ref.trait_id, None) diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 3d0fe75f..564ffafb 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -452,7 +452,7 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for cassert (lp_id = None) trait_decl.meta "TODO: Error message"; extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref; let fun_name = - ctx_get_trait_method trait_ref.trait_decl_ref.trait_decl_id + ctx_get_trait_method meta trait_ref.trait_decl_ref.trait_decl_id method_name ctx in let add_brackets (s : string) = @@ -2236,7 +2236,7 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let trans = A.FunDeclId.Map.find id ctx.trans_funs in (* Extract the items *) let f = trans.f in - let fun_name = ctx_get_trait_method decl.def_id item_name ctx in + let fun_name = ctx_get_trait_method decl.meta decl.def_id item_name ctx in let ty () = (* Extract the generics *) (* We need to add the generics specific to the method, by removing those @@ -2252,7 +2252,7 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params f.meta f.llbc_name f.signature.llbc_generics generics ctx (* TODO: confirm it's the right meta*) + ctx_add_generic_params decl.meta f.llbc_name f.signature.llbc_generics generics ctx (* TODO: confirm it's the right meta*) in let backend_uses_forall = match !backend with Coq | Lean -> true | FStar | HOL4 -> false @@ -2261,7 +2261,7 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let use_forall = generics_not_empty && backend_uses_forall in let use_arrows = generics_not_empty && not backend_uses_forall in let use_forall_use_sep = false in - extract_generic_params f.meta ctx fmt TypeDeclId.Set.empty ~use_forall + extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty ~use_forall ~use_forall_use_sep ~use_arrows generics type_params cg_params trait_clauses; (* TODO: confirm it's the right meta*) if use_forall then F.pp_print_string fmt ","; @@ -2275,7 +2275,7 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (decl : trait_decl) : unit = (* Retrieve the trait name *) - let decl_name = ctx_get_trait_decl decl.def_id ctx in + let decl_name = ctx_get_trait_decl decl.meta decl.def_id ctx in (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) @@ -2331,7 +2331,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt ()) else if is_empty && !backend = Coq then ( (* Coq is not very good at infering constructors *) - let cons = ctx_get_trait_constructor decl.def_id ctx in + let cons = ctx_get_trait_constructor decl.meta decl.def_id ctx in F.pp_print_string fmt (":= " ^ cons ^ "{}."); (* Outer box *) F.pp_close_box fmt ()) @@ -2340,7 +2340,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) | Lean -> F.pp_print_string fmt "where" | FStar -> F.pp_print_string fmt "= {" | Coq -> - let cons = ctx_get_trait_constructor decl.def_id ctx in + let cons = ctx_get_trait_constructor decl.meta decl.def_id ctx in F.pp_print_string fmt (":= " ^ cons ^ " {") | _ -> F.pp_print_string fmt "{"); @@ -2354,7 +2354,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* The constants *) List.iter (fun (name, (ty, _)) -> - let item_name = ctx_get_trait_const decl.def_id name ctx in + let item_name = ctx_get_trait_const decl.meta decl.def_id name ctx in let ty () = let inside = false in F.pp_print_space fmt (); @@ -2367,7 +2367,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun (name, (clauses, _)) -> (* Extract the type *) - let item_name = ctx_get_trait_type decl.def_id name ctx in + let item_name = ctx_get_trait_type decl.meta decl.def_id name ctx in let ty () = F.pp_print_space fmt (); F.pp_print_string fmt (type_keyword decl.meta) @@ -2377,11 +2377,11 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun clause -> let item_name = - ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx + ctx_get_trait_item_clause decl.meta decl.def_id name clause.clause_id ctx in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) clauses) @@ -2392,11 +2392,11 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun clause -> let item_name = - ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + ctx_get_trait_parent_clause decl.meta decl.def_id clause.clause_id ctx in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) decl.parent_clauses; @@ -2433,25 +2433,25 @@ let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) in if num_params > 0 then ( (* The constructor *) - let cons_name = ctx_get_trait_constructor decl.def_id ctx in + let cons_name = ctx_get_trait_constructor decl.meta decl.def_id ctx in extract_coq_arguments_instruction ctx fmt cons_name num_params; (* The constants *) List.iter (fun (name, _) -> - let item_name = ctx_get_trait_const decl.def_id name ctx in + let item_name = ctx_get_trait_const decl.meta decl.def_id name ctx in extract_coq_arguments_instruction ctx fmt item_name num_params) decl.consts; (* The types *) List.iter (fun (name, (clauses, _)) -> (* The type *) - let item_name = ctx_get_trait_type decl.def_id name ctx in + let item_name = ctx_get_trait_type decl.meta decl.def_id name ctx in extract_coq_arguments_instruction ctx fmt item_name num_params; (* The type clauses *) List.iter (fun clause -> let item_name = - ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx + ctx_get_trait_item_clause decl.meta decl.def_id name clause.clause_id ctx in extract_coq_arguments_instruction ctx fmt item_name num_params) clauses) @@ -2460,7 +2460,7 @@ let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun clause -> let item_name = - ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + ctx_get_trait_parent_clause decl.meta decl.def_id clause.clause_id ctx in extract_coq_arguments_instruction ctx fmt item_name num_params) decl.parent_clauses; @@ -2468,7 +2468,7 @@ let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun (item_name, _) -> (* Extract the items *) - let item_name = ctx_get_trait_method decl.def_id item_name ctx in + let item_name = ctx_get_trait_method decl.meta decl.def_id item_name ctx in extract_coq_arguments_instruction ctx fmt item_name num_params) decl.required_methods; (* Add a space *) @@ -2493,7 +2493,7 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let trans = A.FunDeclId.Map.find id ctx.trans_funs in (* Extract the items *) let f = trans.f in - let fun_name = ctx_get_trait_method trait_decl_id item_name ctx in + let fun_name = ctx_get_trait_method impl.meta trait_decl_id item_name ctx in let ty () = (* Filter the generics if the method is a builtin *) let i_tys, _, _ = impl_generics in @@ -2533,16 +2533,16 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, f_tys, f_cgs, f_tcs = - ctx_add_generic_params f.meta f.llbc_name f.signature.llbc_generics f_generics + ctx_add_generic_params impl.meta f.llbc_name f.signature.llbc_generics f_generics ctx in let use_forall = f_generics <> empty_generic_params in - extract_generic_params f.meta ctx fmt TypeDeclId.Set.empty ~use_forall f_generics + extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty ~use_forall f_generics f_tys f_cgs f_tcs; if use_forall then F.pp_print_string fmt ","; (* Extract the function call *) F.pp_print_space fmt (); - let fun_name = ctx_get_local_function f.meta f.def_id None ctx in + let fun_name = ctx_get_local_function impl.meta f.def_id None ctx in F.pp_print_string fmt fun_name; let all_generics = let _, i_cgs, i_tcs = impl_generics in @@ -2565,7 +2565,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (impl : trait_impl) : unit = log#ldebug (lazy ("extract_trait_impl: " ^ name_to_string ctx impl.llbc_name)); (* Retrieve the impl name *) - let impl_name = ctx_get_trait_impl impl.def_id ctx in + let impl_name = ctx_get_trait_impl impl.meta impl.def_id ctx in (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) @@ -2629,7 +2629,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt ()) else if is_empty && !Config.backend = Coq then ( (* Coq is not very good at infering constructors *) - let cons = ctx_get_trait_constructor impl.impl_trait.trait_decl_id ctx in + let cons = ctx_get_trait_constructor impl.meta impl.impl_trait.trait_decl_id ctx in F.pp_print_string fmt (":= " ^ cons ^ "."); (* Outer box *) F.pp_close_box fmt ()) @@ -2653,7 +2653,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* The constants *) List.iter (fun (provided_id, (name, (_, id))) -> - let item_name = ctx_get_trait_const trait_decl_id name ctx in + let item_name = ctx_get_trait_const impl.meta trait_decl_id name ctx in (* The parameters are not the same depending on whether the constant is a provided constant or not *) let print_params () = @@ -2683,7 +2683,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun (name, (trait_refs, ty)) -> (* Extract the type *) - let item_name = ctx_get_trait_type trait_decl_id name ctx in + let item_name = ctx_get_trait_type impl.meta trait_decl_id name ctx in let ty () = F.pp_print_space fmt (); extract_ty impl.meta ctx fmt TypeDeclId.Set.empty false ty @@ -2693,7 +2693,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) TraitClauseId.iteri (fun clause_id trait_ref -> let item_name = - ctx_get_trait_item_clause trait_decl_id name clause_id ctx + ctx_get_trait_item_clause impl.meta trait_decl_id name clause_id ctx in let ty () = F.pp_print_space fmt (); @@ -2707,7 +2707,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) TraitClauseId.iteri (fun clause_id trait_ref -> let item_name = - ctx_get_trait_parent_clause trait_decl_id clause_id ctx + ctx_get_trait_parent_clause impl.meta trait_decl_id clause_id ctx in let ty () = F.pp_print_space fmt (); diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 6e799bd9..c2e3e35f 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -688,48 +688,41 @@ let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) (ctx : extraction let ctx_get_assumed_type ?(meta = None) (id : assumed_ty) (ctx : extraction_ctx) : string = ctx_get_type ~meta:meta (TAssumed id) ctx -let ctx_get_trait_constructor (id : trait_decl_id) (ctx : extraction_ctx) : +let ctx_get_trait_constructor (meta : Meta.meta) (id : trait_decl_id) (ctx : extraction_ctx) : string = - let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in ctx_get ~meta:(Some meta) (TraitDeclConstructorId id) ctx let ctx_get_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : string = ctx_get ~meta:(Some meta) TraitSelfClauseId ctx -let ctx_get_trait_decl (id : trait_decl_id) (ctx : extraction_ctx) : string = - let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in +let ctx_get_trait_decl (meta : Meta.meta) (id : trait_decl_id) (ctx : extraction_ctx) : string = ctx_get ~meta:(Some meta) (TraitDeclId id) ctx -let ctx_get_trait_impl (id : trait_impl_id) (ctx : extraction_ctx) : string = - let meta = (TraitImplId.Map.find id ctx.trans_trait_impls).meta in +let ctx_get_trait_impl (meta : Meta.meta) (id : trait_impl_id) (ctx : extraction_ctx) : string = ctx_get ~meta:(Some meta) (TraitImplId id) ctx -let ctx_get_trait_item (id : trait_decl_id) (item_name : string) +let ctx_get_trait_item (meta : Meta.meta) (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in ctx_get ~meta:(Some meta) (TraitItemId (id, item_name)) ctx -let ctx_get_trait_const (id : trait_decl_id) (item_name : string) +let ctx_get_trait_const (meta : Meta.meta) (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get_trait_item id item_name ctx + ctx_get_trait_item meta id item_name ctx -let ctx_get_trait_type (id : trait_decl_id) (item_name : string) +let ctx_get_trait_type (meta : Meta.meta) (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get_trait_item id item_name ctx + ctx_get_trait_item meta id item_name ctx -let ctx_get_trait_method (id : trait_decl_id) (item_name : string) +let ctx_get_trait_method (meta : Meta.meta) (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in ctx_get ~meta:(Some meta) (TraitMethodId (id, item_name)) ctx -let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) +let ctx_get_trait_parent_clause (meta : Meta.meta) (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in ctx_get ~meta:(Some meta) (TraitParentClauseId (id, clause)) ctx -let ctx_get_trait_item_clause (id : trait_decl_id) (item : string) +let ctx_get_trait_item_clause (meta : Meta.meta) (id : trait_decl_id) (item : string) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - let meta = (TraitDeclId.Map.find id ctx.trans_trait_decls).meta in ctx_get ~meta:(Some meta) (TraitItemClauseId (id, item, clause)) ctx let ctx_get_var (meta : Meta.meta) (id : VarId.id) (ctx : extraction_ctx) : string = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 0329d968..b26704ce 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -533,7 +533,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) if !parameterize_trait_types then craise meta "Unimplemented" else let type_name = - ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name + ctx_get_trait_type meta trait_ref.trait_decl_ref.trait_decl_id type_name ctx in let add_brackets (s : string) = @@ -548,7 +548,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) *) match trait_ref.trait_id with | Self -> - assert (trait_ref.generics = empty_generic_args); + cassert (trait_ref.generics = empty_generic_args) "TODO: Error message"; extract_trait_instance_id_with_dot meta ctx fmt no_params_tys false trait_ref.trait_id; F.pp_print_string fmt type_name @@ -587,7 +587,7 @@ and extract_trait_decl_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_decl_ref) : unit = let use_brackets = tr.decl_generics <> empty_generic_args && inside in - let name = ctx_get_trait_decl tr.trait_decl_id ctx in + let name = ctx_get_trait_decl meta tr.trait_decl_id ctx in if use_brackets then F.pp_print_string fmt "("; F.pp_print_string fmt name; (* There is something subtle here: the trait obligations for the implemented @@ -665,19 +665,19 @@ and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F craise meta "Unexpected occurrence of `Self`" else F.pp_print_string fmt "ERROR(\"Unexpected Self\")" | TraitImpl id -> - let name = ctx_get_trait_impl id ctx in + let name = ctx_get_trait_impl meta id ctx in F.pp_print_string fmt name | Clause id -> let name = ctx_get_local_trait_clause meta id ctx in F.pp_print_string fmt name | ParentClause (inst_id, decl_id, clause_id) -> (* Use the trait decl id to lookup the name *) - let name = ctx_get_trait_parent_clause decl_id clause_id ctx in + let name = ctx_get_trait_parent_clause meta decl_id clause_id ctx in extract_trait_instance_id_with_dot meta ctx fmt no_params_tys true inst_id; F.pp_print_string fmt (add_brackets name) | ItemClause (inst_id, decl_id, item_name, clause_id) -> (* Use the trait decl id to lookup the name *) - let name = ctx_get_trait_item_clause decl_id item_name clause_id ctx in + let name = ctx_get_trait_item_clause meta decl_id item_name clause_id ctx in extract_trait_instance_id_with_dot meta ctx fmt no_params_tys true inst_id; F.pp_print_string fmt (add_brackets name) | TraitRef trait_ref -> @@ -1130,12 +1130,12 @@ let extract_comment_with_span (ctx : extraction_ctx) (fmt : F.formatter) in extract_comment fmt (sl @ [ span ] @ name) -let extract_trait_clause_type (* (meta : Meta.meta) TODO check if right meta*) (ctx : extraction_ctx) (fmt : F.formatter) +let extract_trait_clause_type (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = - let trait_name = ctx_get_trait_decl clause.trait_id ctx in + let trait_name = ctx_get_trait_decl meta clause.trait_id ctx in F.pp_print_string fmt trait_name; - let meta = (TraitDeclId.Map.find clause.trait_id ctx.trans_trait_decls).meta in - extract_generic_args meta ctx fmt no_params_tys clause.generics + (* let meta = (TraitDeclId.Map.find clause.trait_id ctx.trans_trait_decls).meta in + *)extract_generic_args meta ctx fmt no_params_tys clause.generics (** Insert a space, if necessary *) let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = @@ -1155,7 +1155,7 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - let trait_id = ctx_get_trait_decl trait_decl.def_id ctx in + let trait_id = ctx_get_trait_decl trait_decl.meta trait_decl.def_id ctx in F.pp_print_string fmt trait_id; List.iter (fun p -> @@ -1258,7 +1258,7 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt no_params_tys clause; + extract_trait_clause_type meta ctx fmt no_params_tys clause; (* ) *) right_bracket as_implicits; if use_arrows then ( -- cgit v1.2.3 From 0f0082c81db8852dff23cd4691af19c434c8be78 Mon Sep 17 00:00:00 2001 From: Escherichia Date: Wed, 27 Mar 2024 10:22:06 +0100 Subject: Added sanity_check and sanity_check_opt_meta helpers and changed sanity checks related cassert to these helpers to have a proper error message --- compiler/AssociatedTypes.ml | 2 +- compiler/Errors.ml | 8 ++++- compiler/Extract.ml | 4 +-- compiler/ExtractBase.ml | 2 +- compiler/ExtractTypes.ml | 6 ++-- compiler/FunsAnalysis.ml | 2 +- compiler/Interpreter.ml | 4 +-- compiler/InterpreterBorrows.ml | 54 +++++++++++++++++----------------- compiler/InterpreterBorrowsCore.ml | 12 ++++---- compiler/InterpreterExpansion.ml | 4 +-- compiler/InterpreterExpressions.ml | 18 ++++++------ compiler/InterpreterLoopsFixedPoint.ml | 8 ++--- compiler/InterpreterLoopsJoinCtxs.ml | 20 ++++++------- compiler/InterpreterLoopsMatchCtxs.ml | 12 ++++---- compiler/InterpreterPaths.ml | 4 +-- compiler/InterpreterProjectors.ml | 10 +++---- compiler/InterpreterStatements.ml | 15 +++++----- compiler/InterpreterUtils.ml | 2 +- compiler/Invariants.ml | 4 +-- compiler/PureMicroPasses.ml | 4 +-- compiler/PureUtils.ml | 6 ++-- compiler/RegionsHierarchy.ml | 4 +-- compiler/SymbolicToPure.ml | 16 +++++----- 23 files changed, 113 insertions(+), 108 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 0ed46e8c..70739b3c 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -51,7 +51,7 @@ let compute_norm_trait_types_from_preds (meta : Meta.meta option) (* Sanity check: the type constraint can't make use of regions - Remark that it would be enough to only visit the field [ty] of the trait type constraint, but for safety we visit all the fields *) - cassert_opt_meta (trait_type_constraint_no_regions c) meta "TODO: error message"; + sanity_check_opt_meta (trait_type_constraint_no_regions c) meta; let { trait_ref; type_name; ty } : trait_type_constraint = c in let trait_ty = TTraitType (trait_ref, type_name) in let trait_ty_ref = get_ref trait_ty in diff --git a/compiler/Errors.ml b/compiler/Errors.ml index 8fb65bc1..4c51720f 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -39,4 +39,10 @@ let cassert_opt_meta (b : bool) (meta : Meta.meta option) (msg : string) = | None -> if b then let () = save_error (None) msg in - raise (CFailure msg) \ No newline at end of file + raise (CFailure msg) + +let sanity_check b meta = cassert b meta "Internal error, please file an issue" +let sanity_check_opt_meta b meta = cassert_opt_meta b meta "Internal error, please file an issue" + +let exec_raise = craise +let exec_assert = cassert \ No newline at end of file diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 564ffafb..82656273 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -277,7 +277,7 @@ let lets_require_wrap_in_do (meta : Meta.meta) (lets : (bool * typed_pattern * t | HOL4 -> (* HOL4 is similar to HOL4, but we add a sanity check *) let wrap_in_do = List.exists (fun (m, _, _) -> m) lets in - if wrap_in_do then cassert (List.for_all (fun (m, _, _) -> m) lets) meta "TODO: error message"; + if wrap_in_do then sanity_check (List.for_all (fun (m, _, _) -> m) lets) meta; wrap_in_do | FStar | Coq -> false @@ -478,7 +478,7 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for F.pp_print_string fmt fun_name); (* Sanity check: HOL4 doesn't support const generics *) - cassert (generics.const_generics = [] || !backend <> HOL4) meta "TODO: error message"; + sanity_check (generics.const_generics = [] || !backend <> HOL4) meta; (* Print the generics. We might need to filter some of the type arguments, if the type diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index c2e3e35f..1c21e99c 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1904,7 +1904,7 @@ let ctx_compute_fun_name (def : fun_decl) (ctx : extraction_ctx) : string = let ctx_add_fun_decl (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = (* Sanity check: the function should not be a global body - those are handled * separately *) - cassert (not def.is_global_decl_body) def.meta "The function should not be a global body - those are handled separately"; + sanity_check (not def.is_global_decl_body) def.meta; (* Lookup the LLBC def to compute the region group information *) let def_id = def.def_id in (* Add the function name *) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index b26704ce..02aaec65 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -878,7 +878,7 @@ let extract_type_decl_variant (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields in (* Sanity check: HOL4 doesn't support const generics *) - cassert (cg_params = [] || !backend <> HOL4) meta "TODO: Error message"; + sanity_check (cg_params = [] || !backend <> HOL4) meta; (* Print the final type *) if !backend <> HOL4 then ( F.pp_print_space fmt (); @@ -1324,7 +1324,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) (extract_body : bool) : unit = (* Sanity check *) - cassert (extract_body || !backend <> HOL4) def.meta "TODO: error message"; + sanity_check (extract_body || !backend <> HOL4) def.meta; let is_tuple_struct = TypesUtils.type_decl_from_decl_id_is_tuple_struct ctx.trans_ctx.type_ctx.type_infos def.def_id @@ -1489,7 +1489,7 @@ let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) (* Retrieve the definition name *) let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Sanity check *) - cassert (def.generics = empty_generic_params) def.meta "TODO: error message"; + sanity_check (def.generics = empty_generic_params) def.meta; (* Generate the declaration *) F.pp_print_space fmt (); F.pp_print_string fmt ("Type " ^ def_name ^ " = “: unit”"); diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 14185a3d..f3840a8c 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -145,7 +145,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) end in (* Sanity check: global bodies don't contain stateful calls *) - cassert ((not f.is_global_decl_body) || not !stateful) f.meta "Global bodies should not contain stateful calls"; + sanity_check ((not f.is_global_decl_body) || not !stateful) f.meta; let builtin_info = get_builtin_info f in let has_builtin_info = builtin_info <> None in group_has_builtin_info := !group_has_builtin_info || has_builtin_info; diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 2ac772ae..0bbde79c 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -628,8 +628,8 @@ module Test = struct fdef.name)); (* Sanity check - *) - cassert (fdef.signature.generics = empty_generic_params) fdef.meta "TODO: Error message"; - cassert (body.arg_count = 0) fdef.meta "TODO: Error message"; + sanity_check (fdef.signature.generics = empty_generic_params) fdef.meta; + sanity_check (body.arg_count = 0) fdef.meta; (* Create the evaluation context *) let ctx = initialize_eval_ctx fdef.meta decls_ctx [] [] [] in diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index c7df2eca..ab2639ad 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -248,8 +248,8 @@ let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id opt let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv : typed_value) (ctx : eval_ctx) : eval_ctx = (* Sanity check *) - cassert (not (loans_in_value nv)) meta "TODO: error message"; - cassert (not (bottom_in_value ctx.ended_regions nv)) meta "TODO: error message"; + sanity_check (not (loans_in_value nv)) meta; + sanity_check (not (bottom_in_value ctx.ended_regions nv)) meta; (* Debug *) log#ldebug (lazy @@ -444,7 +444,7 @@ let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) - cassert (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) meta "TODO: error message"; + sanity_check (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) meta; (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in (* Substitution function, to replace the borrow projectors over symbolic values *) @@ -559,7 +559,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) ( * we don't register the fact that we inserted the value somewhere * (i.e., we don't call {!set_replaced}) *) (* Sanity check *) - cassert (nv.ty = ty) meta "TODO: error message"; + sanity_check (nv.ty = ty) meta; ALoan (AEndedIgnoredMutLoan { given_back = nv; child; given_back_meta = nsv })) @@ -758,24 +758,24 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_bor match bc with | Concrete (VMutBorrow (l', tv)) -> (* Sanity check *) - cassert (l' = l) meta "TODO: error message"; - cassert (not (loans_in_value tv)) meta "TODO: error message"; + sanity_check (l' = l) meta; + sanity_check (not (loans_in_value tv)) meta; (* Check that the corresponding loan is somewhere - purely a sanity check *) - cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The corresponding loan should be somewhere"; + sanity_check (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; (* Update the context *) give_back_value config meta l tv ctx | Concrete (VSharedBorrow l' | VReservedMutBorrow l') -> (* Sanity check *) - cassert (l' = l) meta "TODO: error message"; + sanity_check (l' = l) meta; (* Check that the borrow is somewhere - purely a sanity check *) - cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The borrow should be somewhere"; + sanity_check (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; (* Update the context *) give_back_shared config meta l ctx | Abstract (AMutBorrow (l', av)) -> (* Sanity check *) - cassert (l' = l) meta "TODO: error message"; + sanity_check (l' = l) meta; (* Check that the corresponding loan is somewhere - purely a sanity check *) - cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The corresponding loan should be somewhere"; + sanity_check (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; (* Convert the avalue to a (fresh symbolic) value. Rem.: we shouldn't do this here. We should do this in a function @@ -788,14 +788,14 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_bor ctx | Abstract (ASharedBorrow l') -> (* Sanity check *) - cassert (l' = l) meta "TODO: error message"; + sanity_check (l' = l) meta; (* Check that the borrow is somewhere - purely a sanity check *) - cassert (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta "The borrow should be somewhere"; + sanity_check (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; (* Update the context *) give_back_shared config meta l ctx | Abstract (AProjSharedBorrow asb) -> (* Sanity check *) - cassert (borrow_in_asb l asb) meta "TODO: error message"; + sanity_check (borrow_in_asb l asb) meta; (* Update the context *) give_back_shared config meta l ctx | Abstract @@ -931,7 +931,7 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_a (* Sanity check: the borrowed value shouldn't contain loans *) (match bc with | Concrete (VMutBorrow (_, bv)) -> - cassert (Option.is_none (get_first_loan_in_value bv)) meta "Borrowed value shouldn't contain loans" + sanity_check (Option.is_none (get_first_loan_in_value bv)) meta | _ -> ()); (* Give back the value *) let ctx = give_back config meta l bc ctx in @@ -1402,9 +1402,9 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow * replace it with... Maybe we should introduce an ABottomProj? *) let ctx = update_aproj_borrows meta abs_id sv AIgnoredProjBorrows ctx in (* Sanity check: no other occurrence of an intersecting projector of borrows *) - cassert ( + sanity_check ( Option.is_none - (lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx)) meta "no other occurrence of an intersecting projector of borrows"; + (lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx)) meta ; (* End the projector of loans *) let ctx = update_aproj_loans_to_ended meta abs_id sv ctx in (* Sanity check *) @@ -1483,7 +1483,7 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) (* We need to check that there aren't any loans in the value: we should have gotten rid of those already, but it is better to do a sanity check. *) - cassert (not (loans_in_value sv)) meta "There shouldn't be any loans in the value"; + sanity_check (not (loans_in_value sv)) meta; (* Check there isn't {!Bottom} (this is actually an invariant *) cassert (not (bottom_in_value ctx.ended_regions sv)) meta "There shouldn't be a !Bottom"; (* Check there aren't reserved borrows *) @@ -1564,9 +1564,9 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) (l : Bo (lazy ("activate_reserved_mut_borrow: resulting value:\n" ^ typed_value_to_string meta ctx sv)); - cassert (not (loans_in_value sv)) meta "TODO: error message"; - cassert (not (bottom_in_value ctx.ended_regions sv)) meta "TODO: error message"; - cassert (not (reserved_in_value sv)) meta "TODO: error message"; + sanity_check (not (loans_in_value sv)) meta; + sanity_check (not (bottom_in_value ctx.ended_regions sv)) meta; + sanity_check (not (reserved_in_value sv)) meta; (* End the borrows which borrow from the value, at the exception of the borrow we want to promote *) let bids = BorrowId.Set.remove l bids in @@ -1664,7 +1664,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) list_avalues false push_fail child_av) | ABorrow bc -> ( (* Sanity check - rem.: may be redundant with [push_fail] *) - cassert allow_borrows meta "TODO: error message"; + sanity_check allow_borrows meta; (* Explore the borrow content *) match bc with | AMutBorrow (bid, child_av) -> @@ -1854,7 +1854,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ let _, ref_ty, kind = ty_as_ref ty in cassert (ty_no_regions ref_ty) meta "TODO: error message"; (* Sanity check *) - cassert allow_borrows meta "TODO: error message"; + sanity_check allow_borrows meta; (* Convert the borrow content *) match bc with | VSharedBorrow bid -> @@ -2068,7 +2068,7 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) (abs : ab method! visit_symbolic_value _ sv = (* Sanity check: no borrows *) - cassert (not (symbolic_value_has_borrows ctx sv)) meta "TODO: error message" + sanity_check (not (symbolic_value_has_borrows ctx sv)) meta end in @@ -2173,8 +2173,8 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) if merge_funs = None then ( - cassert (BorrowId.Set.disjoint borrows0 borrows1) meta "TODO: error message"; - cassert (BorrowId.Set.disjoint loans0 loans1)) meta "TODO: error message"; + sanity_check (BorrowId.Set.disjoint borrows0 borrows1) meta; + sanity_check (BorrowId.Set.disjoint loans0 loans1)) meta; (* Merge. There are several cases: @@ -2476,7 +2476,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end in (* Sanity check *) - if !Config.sanity_checks then cassert (abs_is_destructured meta true ctx abs) meta "TODO: error message"; + if !Config.sanity_checks then sanity_check (abs_is_destructured meta true ctx abs) meta; (* Return *) abs diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index a9a98b5c..d61e0bd1 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -100,7 +100,7 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool = let compare = compare_rtys meta default combine compare_regions in (* Sanity check - TODO: don't do this at every recursive call *) - cassert (ty_is_rty ty1 && ty_is_rty ty2) meta "ty1 or ty2 are not rty TODO: Error message"; + sanity_check (ty_is_rty ty1 && ty_is_rty ty2) meta; (* Normalize the associated types *) match (ty1, ty2) with | TLiteral lit1, TLiteral lit2 -> @@ -144,7 +144,7 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool combine params_b tys_b | TRef (r1, ty1, kind1), TRef (r2, ty2, kind2) -> (* Sanity check *) - cassert (kind1 = kind2) meta "kind1 and kind2 are not equal TODO: Error message"; + sanity_check (kind1 = kind2) meta; (* Explanation for the case where we check if projections intersect: * the projections intersect if the borrows intersect or their contents * intersect. *) @@ -795,7 +795,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo (* Small helpers for sanity checks *) let shared = ref None in let add_shared () = - match !shared with None -> shared := Some true | Some b -> cassert b meta "TODO : error message " + match !shared with None -> shared := Some true | Some b -> sanity_check b meta in let set_non_shared () = match !shared with @@ -821,7 +821,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo method! visit_abstract_shared_borrows abs asb = (* Sanity check *) - (match !shared with Some b -> cassert b meta "TODO : error message " | _ -> ()); + (match !shared with Some b -> sanity_check b meta | _ -> ()); (* Explore *) if can_update_shared then let abs = Option.get abs in @@ -1063,7 +1063,7 @@ let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Sanity check *) - cassert !found meta "TODO : error message "; + sanity_check !found meta; (* Return *) ctx @@ -1112,7 +1112,7 @@ let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : sy (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Sanity check *) - cassert !found meta "TODO : error message "; + sanity_check !found meta; (* Return *) ctx diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 2f886714..086c0786 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -557,7 +557,7 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv ^ "\n\n- original context:\n" ^ eval_ctx_to_string meta ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); (* Sanity check: the symbolic value has disappeared *) - cassert (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta "TODO: error message") + sanity_check (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta) in (* Continue *) cc cf ctx @@ -594,7 +594,7 @@ let expand_symbolic_int (config : config) (meta : Meta.meta) (sv : symbolic_valu (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) - cassert (sv.sv_ty = TLiteral (TInteger int_type)) meta "TODO: error message"; + sanity_check (sv.sv_ty = TLiteral (TInteger int_type)) meta; (* For all the branches of the switch, we expand the symbolic value * to the value given by the branch and execute the branch statement. * For the otherwise branch, we leave the symbolic value as it is diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 6c4f8af5..3922a3ab 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -137,7 +137,7 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) | TAdt (TAssumed TBox, _) -> craise meta "Can't copy an assumed value other than Option" | TAdt (TAdtId _, _) as ty -> - cassert (allow_adt_copy || ty_is_primitively_copyable ty) meta "TODO: error message" + sanity_check (allow_adt_copy || ty_is_primitively_copyable ty) meta | TAdt (TTuple, _) -> () (* Ok *) | TAdt ( TAssumed (TSlice | TArray), @@ -147,7 +147,7 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) const_generics = []; trait_refs = []; } ) -> - cassert (ty_is_primitively_copyable ty) meta "TODO: error message" + sanity_check (ty_is_primitively_copyable ty) meta | _ -> craise meta "Unreachable"); let ctx, fields = List.fold_left_map @@ -330,11 +330,11 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan let copy cf v : m_fun = fun ctx -> (* Sanity checks *) - cassert (not (bottom_in_value ctx.ended_regions v)) meta "TODO: error message"; - cassert ( + sanity_check (not (bottom_in_value ctx.ended_regions v)) meta; + sanity_check ( Option.is_none (find_first_primitively_copyable_sv_with_borrows - ctx.type_ctx.type_infos v)) meta "TODO: error message"; + ctx.type_ctx.type_infos v)) meta; (* Actually perform the copy *) let allow_adt_copy = false in let ctx, v = copy_value meta allow_adt_copy config ctx v in @@ -737,9 +737,9 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : | TAdtId def_id -> (* Sanity checks *) let type_decl = ctx_lookup_type_decl ctx def_id in - cassert ( + sanity_check ( List.length type_decl.generics.regions - = List.length generics.regions) meta "TODO: error message"; + = List.length generics.regions) meta; let expected_field_types = AssociatedTypes.ctx_adt_get_inst_norm_field_etypes meta ctx def_id opt_variant_id generics @@ -758,10 +758,10 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : | TAssumed _ -> craise meta "Unreachable") | AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) - cassert (List.for_all (fun (v : typed_value) -> v.ty = ety) values) meta "All the values do not have the proper type"; + sanity_check (List.for_all (fun (v : typed_value) -> v.ty = ety) values) meta; (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in - cassert (len = Z.of_int (List.length values)) meta "The number of values is not consistent with the length"; + sanity_check (len = Z.of_int (List.length values)) meta; let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in let ty = TAdt (TAssumed TArray, generics) in (* In order to generate a better AST, we introduce a symbolic diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index ef2c5698..44b9a44e 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -267,9 +267,9 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f borrow_substs := (lid, nlid) :: !borrow_substs; (* Rem.: the below sanity checks are not really necessary *) - cassert (AbstractionId.Set.is_empty abs.parents) meta "abs.parents is not empty TODO: Error message"; - cassert (abs.original_parents = []) meta "original_parents is not empty TODO: Error message"; - cassert (RegionId.Set.is_empty abs.ancestors_regions) meta "ancestors_regions is not empty TODO: Error message"; + sanity_check (AbstractionId.Set.is_empty abs.parents) meta; + sanity_check (abs.original_parents = []) meta; + sanity_check (RegionId.Set.is_empty abs.ancestors_regions) meta; (* Introduce the new abstraction for the shared values *) cassert (ty_no_regions sv.ty) meta "TODO : error message "; @@ -323,7 +323,7 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f let collect_shared_values_in_abs (abs : abs) : unit = let collect_shared_value lids (sv : typed_value) = (* Sanity check: we don't support nested borrows for now *) - cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows not supported yet"; + sanity_check (not (value_has_borrows ctx sv.value)) meta; (* Filter the loan ids whose corresponding borrows appear in abstractions (see the documentation of the function) *) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index c4709b7e..74d31975 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -307,8 +307,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id *) let merge_amut_borrows id ty0 child0 _ty1 child1 = (* Sanity checks *) - cassert (is_aignored child0.value) meta "Children are not [AIgnored]"; - cassert (is_aignored child1.value) meta "Children are not [AIgnored]"; + sanity_check (is_aignored child0.value) meta; + sanity_check (is_aignored child1.value) meta; (* We need to pick a type for the avalue. The types on the left and on the right may use different regions: it doesn't really matter (here, we pick @@ -326,8 +326,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id let _ = let _, ty0, _ = ty_as_ref ty0 in let _, ty1, _ = ty_as_ref ty1 in - cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) meta "TODO: error message"; - cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) meta "TODO: error message" + sanity_check (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) meta; + sanity_check (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) meta in (* Same remarks as for [merge_amut_borrows] *) @@ -338,8 +338,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id let merge_amut_loans id ty0 child0 _ty1 child1 = (* Sanity checks *) - cassert (is_aignored child0.value) meta "Children are not [AIgnored]"; - cassert (is_aignored child1.value) meta "Children are not [AIgnored]"; + sanity_check (is_aignored child0.value) meta; + sanity_check (is_aignored child1.value) meta; (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in let child = child0 in @@ -349,8 +349,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id let merge_ashared_loans ids ty0 (sv0 : typed_value) child0 _ty1 (sv1 : typed_value) child1 = (* Sanity checks *) - cassert (is_aignored child0.value) meta "Children are not [AIgnored]"; - cassert (is_aignored child1.value) meta "Children are not [AIgnored]"; + sanity_check (is_aignored child0.value) meta; + sanity_check (is_aignored child1.value) meta; (* Same remarks as for [merge_amut_borrows]. This time we need to also merge the shared values. We rely on the @@ -425,9 +425,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (* Variables are necessarily in the prefix *) craise meta "Unreachable" | EBinding (BDummy did, _) -> - cassert (not (DummyVarId.Set.mem did fixed_ids.dids)) meta "TODO: error message" + sanity_check (not (DummyVarId.Set.mem did fixed_ids.dids)) meta | EAbs abs -> - cassert (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) meta "TODO: error message" + sanity_check (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) meta | EFrame -> (* This should have been eliminated *) craise meta "Unreachable" diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 2e700c50..435174a7 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -43,8 +43,8 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) match Id0.Map.find_opt id0 !map with | None -> () | Some set -> - cassert ( - (not check_not_already_registered) || not (Id1.Set.mem id1 set)) meta "TODO: error message"); + sanity_check ( + (not check_not_already_registered) || not (Id1.Set.mem id1 set)) meta); (* Update the mapping *) map := Id0.Map.update id0 @@ -53,10 +53,10 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) | None -> Some (Id1.Set.singleton id1) | Some ids -> (* Sanity check *) - cassert (not check_singleton_sets) meta "TODO: error message"; - cassert ( + sanity_check (not check_singleton_sets) meta; + sanity_check ( (not check_not_already_registered) - || not (Id1.Set.mem id1 ids)) meta "TODO: error message"; + || not (Id1.Set.mem id1 ids)) meta; (* Update *) Some (Id1.Set.add id1 ids)) !map @@ -691,7 +691,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let id1 = sv1.sv_id in if id0 = id1 then ( (* Sanity check *) - cassert (sv0 = sv1) meta "TODO: error message"; + sanity_check (sv0 = sv1) meta; (* Return *) sv0) else ( diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 6ec12d6f..3733c06d 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -603,7 +603,7 @@ let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) (* Reinsert *) let ctx = write_place meta access p v ctx in (* Sanity check *) - cassert (not (outer_loans_in_value v)) meta "TODO: Error message"; + sanity_check (not (outer_loans_in_value v)) meta; (* Continue *) cf ctx) in @@ -627,7 +627,7 @@ let prepare_lplace (config : config) (meta : Meta.meta) (p : place) (cf : typed_ fun ctx -> let v = read_place meta access p ctx in (* Sanity checks *) - cassert (not (outer_loans_in_value v)) meta "TODO: Error message"; + sanity_check (not (outer_loans_in_value v)) meta; (* Continue *) cf v ctx in diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 7eaa7659..5f83b938 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -18,7 +18,7 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) (* Sanity check - TODO: move those elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Subst.erase_regions ty in - cassert (ty_is_rty ty && ety = v.ty) meta "TODO: error message"; + sanity_check (ty_is_rty ty && ety = v.ty) meta; (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then [] else @@ -95,7 +95,7 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Substitute.erase_regions ty in - cassert (ty_is_rty ty && ety = v.ty) meta "TODO: error message"; + sanity_check (ty_is_rty ty && ety = v.ty) meta; (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then { value = AIgnored; ty } else @@ -261,7 +261,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI (original_sv_ty : rty) : typed_avalue = (* Sanity check: if we have a proj_loans over a symbolic value, it should * contain regions which we will project *) - cassert (ty_has_regions_in_set regions original_sv_ty) meta "TODO: error message"; + sanity_check (ty_has_regions_in_set regions original_sv_ty) meta; (* Match *) let (value, ty) : avalue * ty = match (see, original_sv_ty) with @@ -276,7 +276,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI (AAdt { variant_id; field_values }, original_sv_ty) | SeMutRef (bid, spc), TRef (r, ref_ty, RMut) -> (* Sanity check *) - cassert (spc.sv_ty = ref_ty) meta "TODO: error message"; + sanity_check (spc.sv_ty = ref_ty) meta; (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in (* Check if the region is in the set of projected regions (note that @@ -294,7 +294,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI (ALoan (AIgnoredMutLoan (opt_bid, child_av)), ref_ty) | SeSharedRef (bids, spc), TRef (r, ref_ty, RShared) -> (* Sanity check *) - cassert (spc.sv_ty = ref_ty) meta "TODO: error message"; + sanity_check (spc.sv_ty = ref_ty) meta; (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in (* Check if the region is in the set of projected regions (note that diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 0d0fd0a5..5e8f7c55 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -354,7 +354,7 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) match ret_value with | None -> () | Some ret_value -> - cassert (not (bottom_in_value ctx.ended_regions ret_value)) meta "TODO: Error message" ) + sanity_check (not (bottom_in_value ctx.ended_regions ret_value)) meta) in (* Drop the outer *loans* we find in the local variables *) @@ -504,8 +504,7 @@ let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) (fi let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - cassert (generics.const_generics = []) meta "The const generic vars environment - in concrete mode is not fully handled yet"; + sanity_check (generics.const_generics = []) meta; (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -1111,7 +1110,7 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_f (* Evaluate the branch *) let cf_eval_branch cf = (* Sanity check *) - cassert (sv.int_ty = int_ty) meta "TODO: Error message"; + sanity_check (sv.int_ty = int_ty) meta; (* Find the branch *) match List.find_opt (fun (svl, _) -> List.mem sv svl) stgts with | None -> eval_statement config otherwise cf @@ -1236,7 +1235,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - cassert (generics.const_generics = []) meta "The const generic vars environment in concrete mode is not fully handled yet"; + sanity_check (generics.const_generics = []) meta; fun cf ctx -> (* Retrieve the (correctly instantiated) body *) let def = ctx_lookup_fun_decl ctx fid in @@ -1323,7 +1322,7 @@ and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) eval_transparent_function_call_symbolic_inst meta call ctx in (* Sanity check *) - cassert (List.length call.args = List.length def.signature.inputs) def.meta "TODO: Error message"; + sanity_check (List.length call.args = List.length def.signature.inputs) def.meta; (* Evaluate the function call *) eval_function_call_symbolic_from_inst_sig config def.meta func def.signature regions_hierarchy inst_sg generics trait_method_generics call.args call.dest @@ -1495,10 +1494,10 @@ and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) (fi let dest = call.dest in (* Sanity check: make sure the type parameters don't contain regions - * this is a current limitation of our synthesis *) - cassert ( + sanity_check ( List.for_all (fun ty -> not (ty_has_borrows ctx.type_ctx.type_infos ty)) - generics.types) meta "The parameters should not contain regions TODO: error message"; + generics.types) meta; (* There are two cases (and this is extremely annoying): - the function is not box_free diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index b5402bb0..be8400f7 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -79,7 +79,7 @@ let mk_place_from_var_id (var_id : VarId.id) : place = (** Create a fresh symbolic value *) let mk_fresh_symbolic_value (meta : Meta.meta) (ty : ty) : symbolic_value = (* Sanity check *) - cassert (ty_is_rty ty) meta "TODO: error message"; + sanity_check (ty_is_rty ty) meta; let sv_id = fresh_symbolic_value_id () in let svalue = { sv_id; sv_ty = ty } in svalue diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index a8077ab7..50f008b8 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -105,8 +105,8 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let reprs = !ids_reprs in let infos = !borrows_infos in (* Sanity checks *) - cassert (not (BorrowId.Map.mem bid reprs)) meta "TODO: Error message"; - cassert (not (BorrowId.Map.mem bid infos)) meta "TODO: Error message"; + sanity_check (not (BorrowId.Map.mem bid reprs)) meta; + sanity_check (not (BorrowId.Map.mem bid infos)) meta; (* Add the mapping for the representant *) let reprs = BorrowId.Map.add bid bid reprs in (* Add the mapping for the loan info *) diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 2fb33036..d7423441 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1240,10 +1240,10 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = if List.for_all (fun (_, y) -> y = x) end_args then ( (* We can substitute *) (* Sanity check: all types correct *) - cassert ( + sanity_check ( List.for_all (fun (generics1, _) -> generics1 = generics) - args) def.meta "All types are not correct"; + args) def.meta; { e with e = Var x }) else super#visit_texpression env e else super#visit_texpression env e diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 05373ce8..0f9c2dfe 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -426,14 +426,14 @@ let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : let mk_switch (meta : Meta.meta) (scrut : texpression) (sb : switch_body) : texpression = (* Sanity check: the scrutinee has the proper type *) (match sb with - | If (_, _) -> cassert (scrut.ty = TLiteral TBool) meta "The scrutinee does not have the proper type" + | If (_, _) -> sanity_check (scrut.ty = TLiteral TBool) meta | Match branches -> List.iter - (fun (b : match_branch) -> cassert (b.pat.ty = scrut.ty) meta "The scrutinee does not have the proper type") + (fun (b : match_branch) -> sanity_check (b.pat.ty = scrut.ty) meta) branches); (* Sanity check: all the branches have the same type *) let ty = get_switch_body_ty sb in - iter_switch_body_branches (fun e -> cassert (e.ty = ty) meta "All branches should have the same type") sb; + iter_switch_body_branches (fun e -> sanity_check (e.ty = ty) meta) sb; (* Put together *) let e = Switch (scrut, sb) in { e; ty } diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index 0672a25f..f4e2ff35 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -107,8 +107,8 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty let add_edge ~(short : region) ~(long : region) = (* Sanity checks *) - cassert_opt_meta (short <> RErased) meta "TODO: Error message"; - cassert_opt_meta (long <> RErased) meta "TODO: Error message"; + sanity_check_opt_meta (short <> RErased) meta; + sanity_check_opt_meta (long <> RErased) meta; (* Ignore the locally bound regions (at the level of arrow types for instance *) match (short, long) with | RBVar _, _ | _, RBVar _ -> () diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index b62966bd..46058a9a 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -2019,7 +2019,7 @@ and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) | Some _ -> (* Backward function *) (* Sanity check *) - cassert (opt_v = None) ctx.fun_decl.meta "TODO: Error message"; + sanity_check (opt_v = None) ctx.fun_decl.meta; (* Group the variables in which we stored the values we need to give back. See the explanations for the [SynthInput] case in [translate_end_abstraction] *) let backward_outputs = Option.get ctx.backward_outputs in @@ -2429,7 +2429,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) (* TODO: normalize the types *) if !Config.type_check_pure_code then List.iter - (fun (var, v) -> cassert ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta "TODO: error message") + (fun (var, v) -> sanity_check ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta) variables_values; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2584,7 +2584,7 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) ^ pure_ty_to_string ctx given_back.ty ^ "\n- sig input ty: " ^ pure_ty_to_string ctx input.ty)); - cassert (given_back.ty = input.ty) ctx.fun_decl.meta "TODO: error message") + sanity_check (given_back.ty = input.ty) ctx.fun_decl.meta) given_back_inputs; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2799,7 +2799,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) let branch = List.hd branches in let ty = branch.branch.ty in (* Sanity check *) - cassert (List.for_all (fun br -> br.branch.ty = ty) branches) ctx.fun_decl.meta "There should be at least one branch"; + sanity_check (List.for_all (fun br -> br.branch.ty = ty) branches) ctx.fun_decl.meta; (* Return *) { e; ty }) | ExpandBool (true_e, false_e) -> @@ -3377,11 +3377,11 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = in (* Sanity check: all the non-fresh symbolic values are in the context *) - cassert ( + sanity_check ( List.for_all (fun (sv : V.symbolic_value) -> V.SymbolicValueId.Map.mem sv.sv_id ctx.sv_to_var) - loop.input_svalues) ctx.fun_decl.meta "All the non-fresh symbolic values should be in the context"; + loop.input_svalues) ctx.fun_decl.meta; (* Translate the loop inputs *) let inputs = @@ -3736,10 +3736,10 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (List.map (pure_ty_to_string ctx) signature.inputs))); (* TODO: we need to normalize the types *) if !Config.type_check_pure_code then - cassert ( + sanity_check ( List.for_all (fun (var, ty) -> (var : var).ty = ty) - (List.combine inputs signature.inputs)) def.meta "TODO: error message"; + (List.combine inputs signature.inputs)) def.meta; Some { inputs; inputs_lvs; body } in -- cgit v1.2.3 From 5ad671a0960692af1c00609fa6864c6f44ca299c Mon Sep 17 00:00:00 2001 From: Escherichia Date: Thu, 28 Mar 2024 13:56:31 +0100 Subject: Should answer all comments, there are still some TODO: error message left --- compiler/AssociatedTypes.ml | 20 +- compiler/Contexts.ml | 4 +- compiler/Errors.ml | 50 +++-- compiler/Extract.ml | 37 ++-- compiler/ExtractBase.ml | 88 +++++---- compiler/ExtractName.ml | 12 +- compiler/ExtractTypes.ml | 33 ++-- compiler/FunsAnalysis.ml | 4 +- compiler/Interpreter.ml | 16 +- compiler/InterpreterBorrows.ml | 132 +++++++------- compiler/InterpreterBorrowsCore.ml | 54 +++--- compiler/InterpreterExpansion.ml | 36 ++-- compiler/InterpreterExpressions.ml | 68 +++---- compiler/InterpreterLoops.ml | 24 +-- compiler/InterpreterLoopsCore.ml | 32 ++-- compiler/InterpreterLoopsFixedPoint.ml | 44 ++--- compiler/InterpreterLoopsJoinCtxs.ml | 42 +++-- compiler/InterpreterLoopsMatchCtxs.ml | 322 +++++++++++++++++---------------- compiler/InterpreterPaths.ml | 18 +- compiler/InterpreterProjectors.ml | 10 +- compiler/InterpreterStatements.ml | 64 +++---- compiler/InterpreterStatements.mli | 2 +- compiler/InterpreterUtils.ml | 22 +-- compiler/Invariants.ml | 164 ++++++++--------- compiler/Main.ml | 2 +- compiler/PrePasses.ml | 7 +- compiler/Print.ml | 134 +++++++------- compiler/PrintPure.ml | 102 +++++------ compiler/PureMicroPasses.ml | 13 +- compiler/PureTypeCheck.ml | 64 +++---- compiler/PureUtils.ml | 27 ++- compiler/RegionsHierarchy.ml | 10 +- compiler/Substitute.ml | 6 +- compiler/SymbolicToPure.ml | 68 +++---- compiler/SynthesizeSymbolic.ml | 4 +- compiler/Translate.ml | 14 +- compiler/ValuesUtils.ml | 10 +- 37 files changed, 882 insertions(+), 877 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 70739b3c..a4b0e921 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -239,7 +239,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = match trait_ref.trait_id with | TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ } -> - cassert_opt_meta (ref_generics = empty_generic_args) ctx.meta "Higher order types are not supported yet TODO: error message"; + cassert_opt_meta (ref_generics = empty_generic_args) ctx.meta "Higher order trait types are not supported yet"; log#ldebug (lazy ("norm_ctx_normalize_ty: trait type: trait ref: " @@ -279,7 +279,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* We can't project *) - cassert_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta "TODO: error message"; + sanity_check_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta ; TTraitType (trait_ref, type_name) in let tr : trait_type_ref = { trait_ref; type_name } in @@ -347,7 +347,7 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) match impl with | None -> (* This is actually a local clause *) - cassert_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta "TODO: error message"; + sanity_check_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta ; (ParentClause (inst_id, decl_id, clause_id), None) | Some impl -> (* We figure out the parent clause by doing the following: @@ -378,7 +378,7 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) match impl with | None -> (* This is actually a local clause *) - cassert_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta "Trait instance id is not a local clause"; + sanity_check_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta ; (ItemClause (inst_id, decl_id, item_name, clause_id), None) | Some impl -> (* We figure out the item clause by doing the following: @@ -511,7 +511,7 @@ let ctx_normalize_trait_type_constraint (meta : Meta.meta) (ctx : eval_ctx) norm_ctx_normalize_trait_type_constraint (mk_norm_ctx meta ctx) ttc (** Same as [type_decl_get_instantiated_variants_fields_types] but normalizes the types *) -let type_decl_get_inst_norm_variants_fields_rtypes (ctx : eval_ctx) +let type_decl_get_inst_norm_variants_fields_rtypes (meta : Meta.meta) (ctx : eval_ctx) (def : type_decl) (generics : generic_args) : (VariantId.id option * ty list) list = let res = @@ -519,16 +519,16 @@ let type_decl_get_inst_norm_variants_fields_rtypes (ctx : eval_ctx) in List.map (fun (variant_id, types) -> - (variant_id, List.map (ctx_normalize_ty def.meta ctx) types)) + (variant_id, List.map (ctx_normalize_ty meta ctx) types)) res (** Same as [type_decl_get_instantiated_field_types] but normalizes the types *) -let type_decl_get_inst_norm_field_rtypes (ctx : eval_ctx) (def : type_decl) +let type_decl_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (def : type_decl) (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in - List.map (ctx_normalize_ty def.meta ctx) types + List.map (ctx_normalize_ty meta ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (adt : adt_value) @@ -540,12 +540,12 @@ let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (** Same as [ctx_adt_value_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let type_decl_get_inst_norm_field_etypes (ctx : eval_ctx) (def : type_decl) +let type_decl_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) (def : type_decl) (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in - let types = List.map (ctx_normalize_ty def.meta ctx) types in + let types = List.map (ctx_normalize_ty meta ctx) types in List.map Subst.erase_regions types (** Same as [ctx_adt_get_instantiated_field_types] but normalizes the types and diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 558aaa4e..51392edf 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -371,7 +371,7 @@ let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) (n is important). *) let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - cassert (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty) meta "Pushed variables and their values do not have the same type TODO: Error message"; + cassert (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty) meta "The pushed variables and their values do not have the same type"; let bv = var_to_binder var in { ctx with env = EBinding (BVar bv, v) :: ctx.env } @@ -395,7 +395,7 @@ let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : (var * typed_value List.for_all (fun (var, (value : typed_value)) -> TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) - vars) meta "Pushed variables and their values do not have the same type TODO: Error message"; + vars) meta "The pushed variables and their values do not have the same type TODO: Error message"; let vars = List.map (fun (var, value) -> EBinding (BVar (var_to_binder var), value)) diff --git a/compiler/Errors.ml b/compiler/Errors.ml index 4c51720f..aff62022 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -11,38 +11,48 @@ let format_error_message (meta : Meta.meta) msg = exception CFailure of string - let error_list : (Meta.meta option * string) list ref = ref [] -let save_error (meta : Meta.meta option) (msg : string) = error_list := (meta, msg)::(!error_list) - -let craise (meta : Meta.meta) (msg : string) = - if !Config.fail_hard then - raise (Failure (format_error_message meta msg)) - else - let () = save_error (Some meta) msg in - raise (CFailure msg) +let push_error (meta : Meta.meta option) (msg : string) = error_list := (meta, msg)::(!error_list) -let cassert (b : bool) (meta : Meta.meta) (msg : string) = - if b then - craise meta msg +let save_error ?(b : bool = true) (meta : Meta.meta option) (msg : string) = + push_error meta msg; + match meta with + | Some m -> + if !Config.fail_hard && b then + raise (Failure (format_error_message m msg)) + | None -> + if !Config.fail_hard && b then + raise (Failure msg) let craise_opt_meta (meta : Meta.meta option) (msg : string) = match meta with - | Some m -> craise m msg + | Some m -> + if !Config.fail_hard then + raise (Failure (format_error_message m msg)) + else + let () = push_error (Some m) msg in + raise (CFailure msg) | None -> - let () = save_error (None) msg in + if !Config.fail_hard then + raise (Failure msg) + else + let () = push_error None msg in raise (CFailure msg) +let craise (meta : Meta.meta) (msg : string) = + craise_opt_meta (Some meta) msg + let cassert_opt_meta (b : bool) (meta : Meta.meta option) (msg : string) = - match meta with - | Some m -> cassert b m msg - | None -> - if b then - let () = save_error (None) msg in - raise (CFailure msg) + if b then + craise_opt_meta meta msg + +let cassert (b : bool) (meta : Meta.meta) (msg : string) = + cassert_opt_meta b (Some meta) msg let sanity_check b meta = cassert b meta "Internal error, please file an issue" let sanity_check_opt_meta b meta = cassert_opt_meta b meta "Internal error, please file an issue" +let internal_error meta = craise meta "Internal error, please report an issue" + let exec_raise = craise let exec_assert = cassert \ No newline at end of file diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 82656273..0e86e187 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -128,8 +128,8 @@ let extract_adt_g_value (meta : Meta.meta) | TAdt (TTuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) - cassert (List.length generics.types = List.length field_values) meta "Only applied tuple constructors are currently supported"; - cassert (generics.const_generics = [] && generics.trait_refs = []) meta "Only applied tuple constructors are currently supported"; + cassert (List.length generics.types = List.length field_values) meta "Only fully applied tuple constructors are currently supported"; + cassert (generics.const_generics = [] && generics.trait_refs = []) meta "Only fully applied tuple constructors are currently supported"; extract_as_tuple () | TAdt (adt_id, _) -> (* "Regular" ADT *) @@ -188,7 +188,6 @@ let extract_adt_g_value (meta : Meta.meta) (* Extract globals in the same way as variables *) let extract_global (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (id : A.GlobalDeclId.id) (generics : generic_args) : unit = - (* let trait_decl = GlobalDeclId.Map.find id ctx.trait_decl_id in there might be a way to extract the meta ? *) let use_brackets = inside && generics <> empty_generic_args in F.pp_open_hvbox fmt ctx.indent_incr; if use_brackets then F.pp_print_string fmt "("; @@ -449,7 +448,7 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for if not method_id.is_provided then ( (* Required method *) - cassert (lp_id = None) trait_decl.meta "TODO: Error message"; + sanity_check (lp_id = None) trait_decl.meta ; extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref; let fun_name = ctx_get_trait_method meta trait_ref.trait_decl_ref.trait_decl_id @@ -498,9 +497,10 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for | Error (types, err) -> extract_generic_args meta ctx fmt TypeDeclId.Set.empty { generics with types }; - if !Config.fail_hard then craise meta err - else - F.pp_print_string fmt + (* if !Config.fail_hard then craise meta err + else *) + save_error (Some meta) err; + F.pp_print_string fmt "(\"ERROR: ill-formed builtin: invalid number of filtering \ arguments\")"); (* Print the arguments *) @@ -645,7 +645,7 @@ and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (* Open parentheses *) if inside then F.pp_print_string fmt "("; (* Print the lambda - note that there should always be at least one variable *) - cassert (xl <> []) meta "TODO: error message"; + sanity_check (xl <> []) meta ; F.pp_print_string fmt "fun"; let with_type = !backend = Coq in let ctx = @@ -944,7 +944,7 @@ and extract_StructUpdate (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.form (inside : bool) (e_ty : ty) (supd : struct_update) : unit = (* We can't update a subset of the fields in Coq (i.e., we can do [{| x:= 3; y := 4 |}], but there is no syntax for [{| s with x := 3 |}]) *) - cassert (!backend <> Coq || supd.init = None) meta "TODO: error message"; + sanity_check (!backend <> Coq || supd.init = None) meta ; (* In the case of HOL4, records with no fields are not supported and are thus extracted to unit. We need to check that by looking up the definition *) let extract_as_unit = @@ -1188,7 +1188,7 @@ let assert_backend_supports_decreases_clauses (meta : Meta.meta) = | FStar | Lean -> () | _ -> craise - meta "decreases clauses only supported for the Lean & F* backends" + meta "Decreases clauses are only supported for the Lean and F* backends" (** Extract a decreases clause function template body. @@ -1208,7 +1208,7 @@ let assert_backend_supports_decreases_clauses (meta : Meta.meta) = *) let extract_template_fstar_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - cassert (!backend = FStar) def.meta "TODO: error message"; + cassert (!backend = FStar) def.meta "The generation of template decrease clauses is only supported for the F* backend"; (* Retrieve the function name *) let def_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in @@ -1273,7 +1273,7 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) *) let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - cassert (!backend = Lean) def.meta "TODO: error message"; + cassert (!backend = Lean) def.meta "The generation of template termination and decreasing clauses is only supported for the Lean backend" ; (* * Extract a template for the termination measure *) @@ -1396,7 +1396,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - cassert (not def.is_global_decl_body) def.meta "TODO: error message"; + sanity_check (not def.is_global_decl_body) def.meta ; (* Retrieve the function name *) let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in (* Add a break before *) @@ -1643,7 +1643,7 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = (* Retrieve the definition name *) let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in - cassert (def.signature.generics.const_generics = []) def.meta "TODO: error message"; + cassert (def.signature.generics.const_generics = []) def.meta "Constant generics are not supported yet when generating code for HOL4"; (* Add the type/const gen parameters - note that we need those bindings only for the generation of the type (they are not top-level) *) let ctx, _, _, _ = @@ -1689,7 +1689,7 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - cassert (not def.is_global_decl_body) def.meta "TODO: error message"; + sanity_check (not def.is_global_decl_body) def.meta ; (* We treat HOL4 opaque functions in a specific manner *) if !backend = HOL4 && Option.is_none def.body then extract_fun_decl_hol4_opaque ctx fmt def @@ -2252,7 +2252,7 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.meta f.llbc_name f.signature.llbc_generics generics ctx (* TODO: confirm it's the right meta*) + ctx_add_generic_params decl.meta f.llbc_name f.signature.llbc_generics generics ctx in let backend_uses_forall = match !backend with Coq | Lean -> true | FStar | HOL4 -> false @@ -2263,7 +2263,7 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let use_forall_use_sep = false in extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty ~use_forall ~use_forall_use_sep ~use_arrows generics type_params cg_params - trait_clauses; (* TODO: confirm it's the right meta*) + trait_clauses; if use_forall then F.pp_print_string fmt ","; (* Extract the inputs and output *) F.pp_print_space fmt (); @@ -2558,8 +2558,7 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) in extract_trait_impl_item ctx fmt fun_name ty -(** Extract a trait implementation - * TODO: check if impl.meta everywhere is the right meta +(** Extract a trait implementation *) let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (impl : trait_impl) : unit = diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 1c21e99c..022643f5 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -262,9 +262,8 @@ let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) \"" ^ name ^ "\":" ^ id1 ^ id2 ^ "\nYou may want to rename some of your definitions, or report an issue." in - log#serror err; (* If we fail hard on errors, raise an exception *) - craise_opt_meta None err + save_error None err let names_map_get_id_from_name (name : string) (nm : names_map) : id option = StringMap.find_opt name nm.name_to_id @@ -296,9 +295,8 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) "Error when registering the name for id: " ^ id_to_string id ^ ":\nThe chosen name is already in the names set: " ^ name in - log#serror err; (* If we fail hard on errors, raise an exception *) - craise_opt_meta None err); + save_error None err); (* Insert *) names_map_add_unchecked id name nm @@ -425,7 +423,7 @@ let names_maps_add (id_to_string : id -> string) (id : id) (name : string) (** The [id_to_string] function to print nice debugging messages if there are collisions *) -let names_maps_get ?(meta = None) (id_to_string : id -> string) (id : id) (nm : names_maps) : +let names_maps_get (meta : Meta.meta option) (id_to_string : id -> string) (id : id) (nm : names_maps) : string = (* We do not use the same name map if we allow/disallow collisions *) let map_to_string (m : string IdMap.t) : string = @@ -445,9 +443,8 @@ let names_maps_get ?(meta = None) (id_to_string : id -> string) (id : id) (nm : "Could not find: " ^ id_to_string id ^ "\nNames map:\n" ^ map_to_string m in - log#serror err; - if !Config.fail_hard then craise_opt_meta meta err - else "(%%%ERROR: unknown identifier\": " ^ id_to_string id ^ "\"%%%)") + save_error meta err; + "(%%%ERROR: unknown identifier\": " ^ id_to_string id ^ "\"%%%)") else let m = nm.names_map.id_to_name in match IdMap.find_opt id m with @@ -457,9 +454,8 @@ let names_maps_get ?(meta = None) (id_to_string : id -> string) (id : id) (nm : "Could not find: " ^ id_to_string id ^ "\nNames map:\n" ^ map_to_string m in - log#serror err; - if !Config.fail_hard then craise_opt_meta meta err - else "(ERROR: \"" ^ id_to_string id ^ "\")" + save_error meta err; + "(ERROR: \"" ^ id_to_string id ^ "\")" type names_map_init = { keywords : string list; @@ -591,17 +587,17 @@ let llbc_fun_id_to_string (ctx : extraction_ctx) = let fun_id_to_string (ctx : extraction_ctx) = PrintPure.regular_fun_id_to_string (extraction_ctx_to_fmt_env ctx) -let adt_variant_to_string ?(meta = None) (ctx : extraction_ctx) = +let adt_variant_to_string (meta : Meta.meta option) (ctx : extraction_ctx) = PrintPure.adt_variant_to_string ~meta:meta (extraction_ctx_to_fmt_env ctx) -let adt_field_to_string ?(meta = None) (ctx : extraction_ctx) = +let adt_field_to_string (meta : Meta.meta option) (ctx : extraction_ctx) = PrintPure.adt_field_to_string ~meta:meta (extraction_ctx_to_fmt_env ctx) (** Debugging function, used when communicating name collisions to the user, and also to print ids for internal debugging (in case of lookup miss for instance). *) -let id_to_string ?(meta = None) (id : id) (ctx : extraction_ctx) : string = +let id_to_string (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : string = let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = let trait_name = trait_decl_id_to_string ctx id in "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" @@ -629,11 +625,11 @@ let id_to_string ?(meta = None) (id : id) (ctx : extraction_ctx) : string = | StructId id -> "struct constructor of: " ^ type_id_to_string ctx id | VariantId (id, variant_id) -> let type_name = type_id_to_string ctx id in - let variant_name = adt_variant_to_string ~meta:meta ctx id (Some variant_id) in + let variant_name = adt_variant_to_string meta ctx id (Some variant_id) in "type name: " ^ type_name ^ ", variant name: " ^ variant_name | FieldId (id, field_id) -> let type_name = type_id_to_string ctx id in - let field_name = adt_field_to_string ~meta:meta ctx id field_id in + let field_name = adt_field_to_string meta ctx id field_id in "type name: " ^ type_name ^ ", field name: " ^ field_name | UnknownId -> "keyword" | TypeVarId id -> "type_var_id: " ^ TypeVarId.to_string id @@ -660,50 +656,50 @@ let id_to_string ?(meta = None) (id : id) (ctx : extraction_ctx) : string = | TraitSelfClauseId -> "trait_self_clause" let ctx_add (meta : Meta.meta) (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = - let id_to_string (id : id) : string = id_to_string ~meta:(Some meta) id ctx in + let id_to_string (id : id) : string = id_to_string (Some meta) id ctx in let names_maps = names_maps_add id_to_string id name ctx.names_maps in { ctx with names_maps } -let ctx_get ?(meta = None) (id : id) (ctx : extraction_ctx) : string = - let id_to_string (id : id) : string = id_to_string ~meta:meta id ctx in - names_maps_get ~meta:meta id_to_string id ctx.names_maps (* TODO check if we can remove the meta arg, same for following functions*) +let ctx_get (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : string = + let id_to_string (id : id) : string = id_to_string meta id ctx in + names_maps_get meta id_to_string id ctx.names_maps let ctx_get_global (meta : Meta.meta) (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (GlobalId id) ctx + ctx_get (Some meta) (GlobalId id) ctx let ctx_get_function (meta : Meta.meta) (id : fun_id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (FunId id) ctx + ctx_get (Some meta) (FunId id) ctx let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) (lp : LoopId.id option) (ctx : extraction_ctx) : string = ctx_get_function meta (FromLlbc (FunId (FRegular id), lp)) ctx -let ctx_get_type ?(meta=None) (id : type_id) (ctx : extraction_ctx) : string = - cassert_opt_meta (id <> TTuple) meta "TODO: error message"; - ctx_get ~meta:meta (TypeId id) ctx +let ctx_get_type (meta : Meta.meta option) (id : type_id) (ctx : extraction_ctx) : string = + sanity_check_opt_meta (id <> TTuple) meta; + ctx_get meta (TypeId id) ctx let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) (ctx : extraction_ctx) : string = - ctx_get_type ~meta:(Some meta) (TAdtId id) ctx + ctx_get_type (Some meta) (TAdtId id) ctx -let ctx_get_assumed_type ?(meta = None) (id : assumed_ty) (ctx : extraction_ctx) : string = - ctx_get_type ~meta:meta (TAssumed id) ctx +let ctx_get_assumed_type (meta : Meta.meta option) (id : assumed_ty) (ctx : extraction_ctx) : string = + ctx_get_type meta (TAssumed id) ctx let ctx_get_trait_constructor (meta : Meta.meta) (id : trait_decl_id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TraitDeclConstructorId id) ctx + ctx_get (Some meta) (TraitDeclConstructorId id) ctx let ctx_get_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) TraitSelfClauseId ctx + ctx_get (Some meta) TraitSelfClauseId ctx let ctx_get_trait_decl (meta : Meta.meta) (id : trait_decl_id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TraitDeclId id) ctx + ctx_get (Some meta) (TraitDeclId id) ctx let ctx_get_trait_impl (meta : Meta.meta) (id : trait_impl_id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TraitImplId id) ctx + ctx_get (Some meta) (TraitImplId id) ctx let ctx_get_trait_item (meta : Meta.meta) (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TraitItemId (id, item_name)) ctx + ctx_get (Some meta) (TraitItemId (id, item_name)) ctx let ctx_get_trait_const (meta : Meta.meta) (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = @@ -715,48 +711,48 @@ let ctx_get_trait_type (meta : Meta.meta) (id : trait_decl_id) (item_name : stri let ctx_get_trait_method (meta : Meta.meta) (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TraitMethodId (id, item_name)) ctx + ctx_get (Some meta) (TraitMethodId (id, item_name)) ctx let ctx_get_trait_parent_clause (meta : Meta.meta) (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TraitParentClauseId (id, clause)) ctx + ctx_get (Some meta) (TraitParentClauseId (id, clause)) ctx let ctx_get_trait_item_clause (meta : Meta.meta) (id : trait_decl_id) (item : string) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TraitItemClauseId (id, item, clause)) ctx + ctx_get (Some meta) (TraitItemClauseId (id, item, clause)) ctx let ctx_get_var (meta : Meta.meta) (id : VarId.id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (VarId id) ctx + ctx_get (Some meta) (VarId id) ctx let ctx_get_type_var (meta : Meta.meta) (id : TypeVarId.id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TypeVarId id) ctx + ctx_get (Some meta) (TypeVarId id) ctx let ctx_get_const_generic_var (meta : Meta.meta) (id : ConstGenericVarId.id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (ConstGenericVarId id) ctx + ctx_get (Some meta) (ConstGenericVarId id) ctx let ctx_get_local_trait_clause (meta : Meta.meta) (id : TraitClauseId.id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (LocalTraitClauseId id) ctx + ctx_get (Some meta) (LocalTraitClauseId id) ctx let ctx_get_field (meta : Meta.meta) (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (FieldId (type_id, field_id)) ctx + ctx_get (Some meta) (FieldId (type_id, field_id)) ctx let ctx_get_struct (meta : Meta.meta) (def_id : type_id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (StructId def_id) ctx + ctx_get (Some meta) (StructId def_id) ctx let ctx_get_variant (meta : Meta.meta) (def_id : type_id) (variant_id : VariantId.id) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (VariantId (def_id, variant_id)) ctx + ctx_get (Some meta) (VariantId (def_id, variant_id)) ctx let ctx_get_decreases_proof (meta : Meta.meta) (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (DecreasesProofId (FRegular def_id, loop_id)) ctx + ctx_get (Some meta) (DecreasesProofId (FRegular def_id, loop_id)) ctx let ctx_get_termination_measure (meta : Meta.meta) (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get ~meta:(Some meta) (TerminationMeasureId (FRegular def_id, loop_id)) ctx + ctx_get (Some meta) (TerminationMeasureId (FRegular def_id, loop_id)) ctx (** Small helper to compute the name of a unary operation *) let unop_name (unop : unop) : string = @@ -1633,7 +1629,7 @@ let ctx_compute_var_basename (meta : Meta.meta) (ctx : extraction_ctx) (basename let cl = to_snake_case name in let cl = String.split_on_char '_' cl in let cl = List.filter (fun s -> String.length s > 0) cl in - cassert (List.length cl > 0) meta "TODO: error message"; + sanity_check (List.length cl > 0) meta; let cl = List.map (fun s -> s.[0]) cl in StringUtils.string_of_chars cl in diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index 9df5b03e..c4e145a0 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -32,7 +32,7 @@ end For impl blocks, we simply use the name of the type (without its arguments) if all the arguments are variables. *) -let pattern_to_extract_name ?(meta = None) (name : pattern) : string list = +let pattern_to_extract_name (meta : Meta.meta option) (name : pattern) : string list = let c = { tgt = TkName } in let all_vars = let check (g : generic_arg) : bool = @@ -92,9 +92,9 @@ let pattern_to_extract_name ?(meta = None) (name : pattern) : string list = let name = visitor#visit_pattern () name in List.map (pattern_elem_to_string c) name -let pattern_to_type_extract_name = pattern_to_extract_name -let pattern_to_fun_extract_name = pattern_to_extract_name -let pattern_to_trait_impl_extract_name = pattern_to_extract_name +let pattern_to_type_extract_name = pattern_to_extract_name None +let pattern_to_fun_extract_name = pattern_to_extract_name None +let pattern_to_trait_impl_extract_name = pattern_to_extract_name None (* TODO: this is provisional. We just want to make sure that the extraction names we derive from the patterns (for the builtin definitions) are @@ -103,7 +103,7 @@ let name_to_simple_name (ctx : ctx) (n : Types.name) : string list = let c : to_pat_config = { tgt = TkName; use_trait_decl_refs = match_with_trait_decl_refs } in - pattern_to_extract_name (name_to_pattern ctx c n) + pattern_to_extract_name None (name_to_pattern ctx c n) (** If the [prefix] is Some, we attempt to remove the common prefix between [prefix] and [name] from [name] *) @@ -125,4 +125,4 @@ let name_with_generics_to_simple_name (ctx : ctx) let _, _, name = pattern_common_prefix { equiv = true } prefix name in name in - pattern_to_extract_name name + pattern_to_extract_name None name diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 02aaec65..a8143876 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -287,7 +287,7 @@ let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt ("val [" ^ String.concat ", " names ^ "] = DefineDiv ‘") else ( - assert (List.length names = 1) (* TODO: Error message, meta todo*); + sanity_check_opt_meta (List.length names = 1) None; let name = List.hd names in F.pp_print_string fmt ("val " ^ name ^ " = Define ‘")); F.pp_print_cut fmt () @@ -470,7 +470,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) if print_paren then F.pp_print_string fmt "("; (* TODO: for now, only the opaque *functions* are extracted in the opaque module. The opaque *types* are assumed. *) - F.pp_print_string fmt (ctx_get_type ~meta:(Some meta) type_id ctx); + F.pp_print_string fmt (ctx_get_type (Some meta) type_id ctx); (* We might need to filter the type arguments, if the type is builtin (for instance, we filter the global allocator type argument for `Vec`). *) @@ -496,7 +496,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) | HOL4 -> let { types; const_generics; trait_refs } = generics in (* Const generics are not supported in HOL4 *) - cassert (const_generics = []) meta "Const generics are not supported in HOL4"; + cassert (const_generics = []) meta "Constant generics are not supported yet when generating code for HOL4"; let print_tys = match type_id with | TAdtId id -> not (TypeDeclId.Set.mem id no_params_tys) @@ -513,7 +513,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (extract_rec true) types; if print_paren then F.pp_print_string fmt ")"; F.pp_print_space fmt ()); - F.pp_print_string fmt (ctx_get_type ~meta:(Some meta) type_id ctx); + F.pp_print_string fmt (ctx_get_type (Some meta) type_id ctx); if trait_refs <> [] then ( F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) @@ -554,7 +554,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt type_name | _ -> (* HOL4 doesn't have 1st class types *) - cassert (!backend <> HOL4) meta "TODO: Error message"; + cassert (!backend <> HOL4) meta "Trait types are not supported yet when generating code for HOL4"; extract_trait_ref meta ctx fmt no_params_tys false trait_ref; F.pp_print_string fmt ("." ^ add_brackets type_name)) @@ -606,7 +606,7 @@ and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.form (extract_ty meta ctx fmt no_params_tys true) types); if const_generics <> [] then ( - cassert (!backend <> HOL4) meta "TODO: Error message"; + cassert (!backend <> HOL4) meta "Constant generics are not supported yet when generating code for HOL4"; F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) (extract_const_generic meta ctx fmt true) @@ -661,9 +661,8 @@ and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F | Self -> (* This has a specific treatment depending on the item we're extracting (associated type, etc.). We should have caught this elsewhere. *) - if !Config.fail_hard then - craise meta "Unexpected occurrence of `Self`" - else F.pp_print_string fmt "ERROR(\"Unexpected Self\")" + save_error (Some meta) "Unexpected occurrence of `Self`"; + F.pp_print_string fmt "ERROR(\"Unexpected Self\")" | TraitImpl id -> let name = ctx_get_trait_impl meta id ctx in F.pp_print_string fmt name @@ -1076,7 +1075,7 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) else ( (* We extract for Coq or Lean, and we have a recursive record, or a record in a group of mutually recursive types: we extract it as an inductive type *) - cassert (is_rec && (!backend = Coq || !backend = Lean)) def.meta "TODO: error message"; + cassert (is_rec && (!backend = Coq || !backend = Lean)) def.meta "Constant generics are not supported yet when generating code for HOL4"; (* Small trick: in Lean we use namespaces, meaning we don't need to prefix the constructor name with the name of the type at definition site, i.e., instead of generating `inductive Foo := | MkFoo ...` like in Coq @@ -1177,7 +1176,7 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* HOL4 doesn't support const generics *) - cassert (cg_params = [] || !backend <> HOL4) meta "HOL4 doesn't support const generics"; + cassert (cg_params = [] || !backend <> HOL4) meta "Constant generics are not supported yet when generating code for HOL4"; let left_bracket (implicit : bool) = if implicit && !backend <> FStar then F.pp_print_string fmt "{" else F.pp_print_string fmt "(" @@ -1395,7 +1394,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) | None -> F.pp_print_string fmt def_name); (* HOL4 doesn't support const generics, and type definitions in HOL4 don't support trait clauses *) - cassert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4) def.meta "HOL4 doesn't support const generics, and type definitions in HOL4 don't support trait clauses"; + cassert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4) def.meta "Constant generics and type definitions with trait clauses are not supported yet when generating code for HOL4"; (* Print the generic parameters *) extract_generic_params def.meta ctx_body fmt type_decl_group ~use_forall def.generics type_params cg_params trait_clauses; @@ -1464,9 +1463,9 @@ let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (* Retrieve the definition name *) let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Generic parameters are unsupported *) - cassert (def.generics.const_generics = []) def.meta "Generic parameters are unsupported"; + cassert (def.generics.const_generics = []) def.meta "Constant generics are not supported yet when generating code for HOL4"; (* Trait clauses on type definitions are unsupported *) - cassert (def.generics.trait_clauses = []) def.meta "Trait clauses on type definitions are unsupported"; + cassert (def.generics.trait_clauses = []) def.meta "Types with trait clauses are not supported yet when generating code for HOL4"; (* Types *) (* Count the number of parameters *) let num_params = List.length def.generics.types in @@ -1565,7 +1564,7 @@ let extract_coq_arguments_instruction (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = - cassert (!backend = Coq) decl.meta "TODO: error message"; + sanity_check (!backend = Coq) decl.meta; (* Generating the [Arguments] instructions is useful only if there are parameters *) let num_params = List.length decl.generics.types @@ -1611,7 +1610,7 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_type_decl_record_field_projectors (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = - cassert (!backend = Coq) decl.meta "TODO: error message"; + sanity_check (!backend = Coq) decl.meta; match decl.kind with | Opaque | Enum _ -> () | Struct fields -> @@ -1782,7 +1781,7 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) * one line *) F.pp_open_hvbox fmt 0; (* Retrieve the name *) - let state_name = ctx_get_assumed_type TState ctx in + let state_name = ctx_get_assumed_type None TState ctx in (* The syntax for Lean and Coq is almost identical. *) let print_axiom () = let axiom = diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index f3840a8c..9ca35e79 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -167,8 +167,8 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) (* We need to know if the declaration group contains a global - note that * groups containing globals contain exactly one declaration *) let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in - cassert ((not is_global_decl_body) || List.length d = 1) (List.hd d).meta "The declaration group should containing globals should contain exactly one declaration"; (*TODO recheck how to get meta*) - cassert ((not !group_has_builtin_info) || List.length d = 1) (List.hd d).meta "The declaration group should containing globals should contain exactly one declaration"; + cassert ((not is_global_decl_body) || List.length d = 1) (List.hd d).meta "This global definition is in a group of mutually recursive definitions"; + cassert ((not !group_has_builtin_info) || List.length d = 1) (List.hd d).meta "This builtin function belongs to a group of mutually recursive definitions"; (* We ignore on purpose functions that cannot fail and consider they *can* * fail: the result of the analysis is not used yet to adjust the translation * so that the functions which syntactically can't fail don't use an error monad. diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 0bbde79c..034304c7 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -211,7 +211,7 @@ let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : in (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) let call_id = fresh_fun_call_id () in - cassert (call_id = FunCallId.zero) fdef.meta "The abstractions should be empty (i.e., with no avalues) abstractions"; + sanity_check (call_id = FunCallId.zero) fdef.meta; let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : eval_ctx * typed_avalue list = (* Project over the values - we use *loan* projectors, as explained above *) @@ -272,7 +272,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) ^ "\n- inside_loop: " ^ Print.bool_to_string inside_loop ^ "\n- ctx:\n" - ^ Print.Contexts.eval_ctx_to_string fdef.meta ctx)); + ^ Print.Contexts.eval_ctx_to_string ~meta:(Some fdef.meta) ctx)); (* We need to instantiate the function signature - to retrieve * the return type. Note that it is important to re-generate * an instantiation of the signature, so that we use fresh @@ -330,7 +330,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) let region_can_end rid = RegionGroupId.Set.mem rid parent_and_current_rgs in - cassert (region_can_end back_id) fdef.meta "The region should be able to end"; + sanity_check (region_can_end back_id) fdef.meta; let ctx = create_push_abstractions_from_abs_region_groups (fun rg_id -> SynthRet rg_id) @@ -417,9 +417,9 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) | Loop (loop_id', rg_id', LoopSynthInput) -> (* We only allow to end the loop synth input abs for the region group [rg_id] *) - cassert ( + sanity_check ( if Option.is_some loop_id then loop_id = Some loop_id' - else true) fdef.meta "Only the loop synth input abs for the region group [rg_id] are allowed to end"; + else true) fdef.meta; (* Loop abstractions *) let rg_id' = Option.get rg_id' in if rg_id' = back_id && inside_loop then @@ -427,7 +427,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) else abs | Loop (loop_id', _, LoopCall) -> (* We can end all the loop call abstractions *) - cassert (loop_id = Some loop_id') fdef.meta "TODO: error message"; + sanity_check (loop_id = Some loop_id') fdef.meta; { abs with can_end = true } | SynthInput rg_id' -> if rg_id' = back_id && end_fun_synth_input then @@ -603,7 +603,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) (* Evaluate the function *) let symbolic = - eval_function_body config fdef.meta (Option.get fdef.body).body cf_finish ctx + eval_function_body config (Option.get fdef.body).body cf_finish ctx in (* Return *) @@ -655,7 +655,7 @@ module Test = struct in (* Evaluate the function *) - let _ = eval_function_body config body.meta body.body cf_check ctx in + let _ = eval_function_body config body.body cf_check ctx in () (** Small helper: return true if the function is a *transparent* unit function diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index ab2639ad..c1cf8441 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -42,7 +42,7 @@ let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id opt in let set_replaced_bc (abs_id : AbstractionId.id option) (bc : g_borrow_content) = - cassert (Option.is_none !replaced_bc) meta "TODO: error message"; + sanity_check (Option.is_none !replaced_bc) meta; replaced_bc := Some (abs_id, bc) in (* Raise an exception if: @@ -224,8 +224,8 @@ let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id opt method! visit_abs outer abs = (* Update the outer abs *) let outer_abs, outer_borrows = outer in - cassert (Option.is_none outer_abs) meta "TODO: error message"; - cassert (Option.is_none outer_borrows) meta "TODO: error message"; + sanity_check (Option.is_none outer_abs) meta; + sanity_check (Option.is_none outer_borrows) meta; let outer = (Some abs.abs_id, None) in super#visit_abs outer abs end @@ -248,18 +248,18 @@ let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id opt let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv : typed_value) (ctx : eval_ctx) : eval_ctx = (* Sanity check *) - sanity_check (not (loans_in_value nv)) meta; - sanity_check (not (bottom_in_value ctx.ended_regions nv)) meta; + exec_assert (not (loans_in_value nv)) meta "Can not end a borrow because the value to give back contains bottom"; + exec_assert (not (bottom_in_value ctx.ended_regions nv)) meta "Can not end a borrow because the value to give back contains bottom"; (* Debug *) log#ldebug (lazy ("give_back_value:\n- bid: " ^ BorrowId.to_string bid ^ "\n- value: " - ^ typed_value_to_string meta ctx nv - ^ "\n- context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); + ^ typed_value_to_string ~meta:(Some meta) ctx nv + ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - cassert (not !replaced) meta "Exactly one loan should have been updated"; + sanity_check (not !replaced) meta; replaced := true in (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) @@ -427,7 +427,7 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv (* We remember in which abstraction we are before diving - * this is necessary for projecting values: we need to know * over which regions to project *) - cassert (Option.is_none opt_abs) meta "TODO: error message"; + sanity_check (Option.is_none opt_abs) meta; super#visit_EAbs (Some abs) abs end in @@ -466,7 +466,7 @@ let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions type [T]! We thus *mustn't* introduce a projector here. *) (* AProjBorrows (nsv, sv.sv_ty) *) - craise meta "TODO: error message" + internal_error meta in AProjLoans (sv, (mv, child_proj) :: local_given_back) in @@ -671,7 +671,7 @@ let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (new_bid : B (* Keep track of changes *) let r = ref false in let set_ref () = - cassert (not !r) meta "TODO: error message"; + sanity_check (not !r) meta; r := true in @@ -701,7 +701,7 @@ let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (new_bid : B let env = obj#visit_env () ctx.env in (* Check that we reborrowed once *) - cassert !r meta "Not reborrowed once"; + sanity_check !r meta; { ctx with env } (** Convert an {!type:avalue} to a {!type:value}. @@ -746,11 +746,11 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_bor (lazy (let bc = match bc with - | Concrete bc -> borrow_content_to_string meta ctx bc - | Abstract bc -> aborrow_content_to_string meta ctx bc + | Concrete bc -> borrow_content_to_string ~meta:(Some meta) ctx bc + | Abstract bc -> aborrow_content_to_string ~meta:(Some meta) ctx bc in "give_back:\n- bid: " ^ BorrowId.to_string l ^ "\n- content: " ^ bc - ^ "\n- context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); + ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* This is used for sanity checks *) let sanity_ek = { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } @@ -814,8 +814,8 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI (lazy (fun_name ^ ": " ^ BorrowId.to_string l ^ ": borrow didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string meta ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); craise meta "Borrow not eliminated" in match lookup_loan_opt meta ek_all l ctx with @@ -825,8 +825,8 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI (lazy (fun_name ^ ": " ^ BorrowId.to_string l ^ ": loan didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string meta ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); craise meta "Loan not eliminated" in unit_to_cm_fun check_disappeared @@ -863,7 +863,7 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_a log#ldebug (lazy ("end borrow: " ^ BorrowId.to_string l ^ ":\n- original context:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Utility function for the sanity checks: check that the borrow disappeared * from the context *) @@ -922,7 +922,7 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_a log#ldebug (lazy "End borrow: borrow not found"); (* It is possible that we can't find a borrow in symbolic mode (ending * an abstraction may end several borrows at once *) - cassert (config.mode = SymbolicMode) meta "Borrow should be in symbolic mode"; + sanity_check (config.mode = SymbolicMode) meta; (* Do a sanity check and continue *) cf_check cf ctx (* We found a borrow and replaced it with [Bottom]: give it back (i.e., update @@ -966,7 +966,7 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string meta ctx0)); + ^ "\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0)); (* Lookup the abstraction - note that if we end a list of abstractions, ending one abstraction may lead to the current abstraction having @@ -999,7 +999,7 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id ^ "\n- context after parent abstractions ended:\n" - ^ eval_ctx_to_string meta ctx))) + ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* End the loans inside the abstraction *) @@ -1010,7 +1010,7 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string meta ctx))) + ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* End the abstraction itself by redistributing the borrows it contains *) @@ -1039,8 +1039,8 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string meta ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string meta ctx))) + ^ "\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* Sanity check: ending an abstraction must preserve the invariants *) @@ -1173,7 +1173,7 @@ and end_abstraction_borrows (config : config) (meta : Meta.meta) (chain : borrow log#ldebug (lazy ("end_abstraction_borrows: found aborrow content: " - ^ aborrow_content_to_string meta ctx bc)); + ^ aborrow_content_to_string ~meta:(Some meta) ctx bc)); let ctx = match bc with | AMutBorrow (bid, av) -> @@ -1243,7 +1243,7 @@ and end_abstraction_borrows (config : config) (meta : Meta.meta) (chain : borrow log#ldebug (lazy ("end_abstraction_borrows: found borrow content: " - ^ borrow_content_to_string meta ctx bc)); + ^ borrow_content_to_string ~meta:(Some meta) ctx bc)); let ctx = match bc with | VSharedBorrow bid -> ( @@ -1466,7 +1466,7 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) log#ldebug (lazy ("promote_shared_loan_to_mut_loan:\n- loan: " ^ BorrowId.to_string l - ^ "\n- context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); + ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* Lookup the shared loan - note that we can't promote a shared loan * in a shared value, but we can do it in a mutably borrowed value. * This is important because we can do: [let y = &two-phase ( *x );] @@ -1485,9 +1485,9 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) to do a sanity check. *) sanity_check (not (loans_in_value sv)) meta; (* Check there isn't {!Bottom} (this is actually an invariant *) - cassert (not (bottom_in_value ctx.ended_regions sv)) meta "There shouldn't be a !Bottom"; + cassert (not (bottom_in_value ctx.ended_regions sv)) meta "There shouldn't be a bottom"; (* Check there aren't reserved borrows *) - cassert (not (reserved_in_value sv)) meta "There shouldn't have reserved borrows"; + cassert (not (reserved_in_value sv)) meta "There shouldn't be reserved borrows"; (* Update the loan content *) let ctx = update_loan meta ek l (VMutLoan l) ctx in (* Continue *) @@ -1563,7 +1563,7 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) (l : Bo log#ldebug (lazy ("activate_reserved_mut_borrow: resulting value:\n" - ^ typed_value_to_string meta ctx sv)); + ^ typed_value_to_string ~meta:(Some meta) ctx sv)); sanity_check (not (loans_in_value sv)) meta; sanity_check (not (bottom_in_value ctx.ended_regions sv)) meta; sanity_check (not (reserved_in_value sv)) meta; @@ -1649,7 +1649,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; - cassert (opt_bid = None) meta "TODO: error message"; + sanity_check (opt_bid = None) meta; (* Simply explore the child *) list_avalues false push_fail child_av | AEndedMutLoan @@ -1680,7 +1680,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) | AIgnoredMutBorrow (opt_bid, child_av) -> (* We don't support nested borrows for now *) cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; - cassert (opt_bid = None) meta "TODO: error message"; + sanity_check (opt_bid = None) meta; (* Just explore the child *) list_avalues false push_fail child_av | AEndedIgnoredMutBorrow @@ -1703,7 +1703,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) | ASymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta "TODO: error message" + sanity_check (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta and list_values (v : typed_value) : typed_avalue list * typed_value = let ty = v.ty in match v.value with @@ -1725,9 +1725,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) let avl, sv = list_values sv in if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) - cassert (ty_no_regions ty) meta "The shared value can't contain loans nor borrows"; + cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; let av : typed_avalue = - cassert (not (value_has_loans_or_borrows ctx sv.value)) meta "The shared value can't contain loans nor borrows"; + sanity_check (not (value_has_loans_or_borrows ctx sv.value)) meta; (* We introduce fresh ids for the symbolic values *) let mk_value_with_fresh_sids (v : typed_value) : typed_value = let visitor = @@ -1752,7 +1752,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) | VSymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta "TODO: error message"; + sanity_check (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta; ([], v) in @@ -1808,7 +1808,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ log#ldebug (lazy ("convert_value_to_abstractions: to_avalues:\n- value: " - ^ typed_value_to_string meta ctx v)); + ^ typed_value_to_string ~meta:(Some meta) ctx v)); let ty = v.ty in match v.value with @@ -1852,13 +1852,13 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ (avl, { v with value = VAdt adt }) | VBorrow bc -> ( let _, ref_ty, kind = ty_as_ref ty in - cassert (ty_no_regions ref_ty) meta "TODO: error message"; + cassert (ty_no_regions ref_ty) meta "Nested borrows are not supported yet"; (* Sanity check *) sanity_check allow_borrows meta; (* Convert the borrow content *) match bc with | VSharedBorrow bid -> - cassert (ty_no_regions ref_ty) meta "TODO: error message"; + cassert (ty_no_regions ref_ty) meta "Nested borrows are not supported yet"; let ty = TRef (RFVar r_id, ref_ty, kind) in let value = ABorrow (ASharedBorrow bid) in ([ { value; ty } ], v) @@ -1887,7 +1887,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - cassert (ty_no_regions ty) meta "TODO: error message"; + cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RShared in let ignored = mk_aignored meta ty in (* Rem.: the shared value might contain loans *) @@ -1905,7 +1905,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ | VMutLoan bid -> (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - cassert (ty_no_regions ty) meta "TODO: error message"; + cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RMut in let ignored = mk_aignored meta ty in let av = ALoan (AMutLoan (bid, ignored)) in @@ -1914,7 +1914,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ | VSymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - cassert (not (value_has_borrows ctx v.value)) meta "TODO: error message"; + cassert (not (value_has_borrows ctx v.value)) meta "Nested borrows are not supported yet"; (* Return nothing *) ([], v) in @@ -1968,26 +1968,26 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) (abs : ab in let push_loans ids (lc : g_loan_content_with_ty) : unit = - cassert (BorrowId.Set.disjoint !loans ids) meta "TODO: error message"; + sanity_check (BorrowId.Set.disjoint !loans ids) meta; loans := BorrowId.Set.union !loans ids; BorrowId.Set.iter (fun id -> - cassert (not (BorrowId.Map.mem id !loan_to_content)) meta "TODO: error message"; + sanity_check (not (BorrowId.Map.mem id !loan_to_content)) meta; loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans) ids in let push_loan id (lc : g_loan_content_with_ty) : unit = - cassert (not (BorrowId.Set.mem id !loans)) meta "TODO: error message"; + sanity_check (not (BorrowId.Set.mem id !loans)) meta; loans := BorrowId.Set.add id !loans; - cassert (not (BorrowId.Map.mem id !loan_to_content)) meta "TODO: error message"; + sanity_check (not (BorrowId.Map.mem id !loan_to_content)) meta; loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans in let push_borrow id (bc : g_borrow_content_with_ty) : unit = - cassert (not (BorrowId.Set.mem id !borrows)) meta "TODO: error message"; + sanity_check (not (BorrowId.Set.mem id !borrows)) meta; borrows := BorrowId.Set.add id !borrows; - cassert (not (BorrowId.Map.mem id !borrow_to_content)) meta "TODO: error message"; + sanity_check (not (BorrowId.Map.mem id !borrow_to_content)) meta; borrow_to_content := BorrowId.Map.add id bc !borrow_to_content; borrows_loans := BorrowId id :: !borrows_loans in @@ -2146,8 +2146,8 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end (* Check that the abstractions are destructured *) if !Config.sanity_checks then ( let destructure_shared_values = true in - cassert (abs_is_destructured meta destructure_shared_values ctx abs0) meta "Abstractions should be destructured"; - cassert (abs_is_destructured meta destructure_shared_values ctx abs1) meta "Abstractions should be destructured"); + sanity_check (abs_is_destructured meta destructure_shared_values ctx abs0) meta; + sanity_check (abs_is_destructured meta destructure_shared_values ctx abs1) meta); (* Compute the relevant information *) let { @@ -2201,7 +2201,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end log#ldebug (lazy ("merge_into_abstraction_aux: push_avalue: " - ^ typed_avalue_to_string meta ctx av)); + ^ typed_avalue_to_string ~meta:(Some meta) ctx av)); avalues := av :: !avalues in let push_opt_avalue av = @@ -2215,7 +2215,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end in let filter_bids (bids : BorrowId.Set.t) : BorrowId.Set.t = let bids = BorrowId.Set.diff bids intersect in - cassert (not (BorrowId.Set.is_empty bids)) meta "TODO: error message"; + sanity_check (not (BorrowId.Set.is_empty bids)) meta; bids in let filter_bid (bid : BorrowId.id) : BorrowId.id option = @@ -2278,7 +2278,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end (* Check that the sets of ids are the same - if it is not the case, it means we actually need to merge more than 2 avalues: we ignore this case for now *) - cassert (BorrowId.Set.equal ids0 ids1) meta "Ids are not the same - Case ignored for now"; + sanity_check (BorrowId.Set.equal ids0 ids1) meta; let ids = ids0 in if BorrowId.Set.is_empty ids then ( (* If the set of ids is empty, we can eliminate this shared loan. @@ -2290,10 +2290,10 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end to preserve (in practice it works because we destructure the shared values in the abstractions, and forbid nested borrows). *) - cassert (not (value_has_loans_or_borrows ctx sv0.value)) meta "TODO: error message"; - cassert (not (value_has_loans_or_borrows ctx sv0.value)) meta "TODO: error message"; - cassert (is_aignored child0.value) meta "TODO: error message"; - cassert (is_aignored child1.value) meta "TODO: error message"; + sanity_check (not (value_has_loans_or_borrows ctx sv0.value)) meta; + sanity_check (not (value_has_loans_or_borrows ctx sv0.value)) meta; + sanity_check (is_aignored child0.value) meta; + sanity_check (is_aignored child1.value) meta; None) else ( (* Register the loan ids *) @@ -2365,7 +2365,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end craise meta "Unreachable" | Abstract (ty, bc) -> { value = ABorrow bc; ty }) | Some bc0, Some bc1 -> - cassert (merge_funs <> None) meta "TODO: error message"; + sanity_check (merge_funs <> None) meta; merge_g_borrow_contents bc0 bc1 | None, None -> craise meta "Unreachable" in @@ -2405,10 +2405,10 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end match lc with | ASharedLoan (bids, sv, child) -> let bids = filter_bids bids in - cassert (not (BorrowId.Set.is_empty bids)) meta "TODO: error message"; - cassert (is_aignored child.value) meta "TODO: error message"; - cassert ( - not (value_has_loans_or_borrows ctx sv.value)) meta "TODO: error message"; + sanity_check (not (BorrowId.Set.is_empty bids)) meta; + sanity_check (is_aignored child.value) meta; + sanity_check ( + not (value_has_loans_or_borrows ctx sv.value)) meta; let lc = ASharedLoan (bids, sv, child) in set_loans_as_merged bids; Some { value = ALoan lc; ty } @@ -2421,7 +2421,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end (* The abstraction has been destructured, so those shouldn't appear *) craise meta "Unreachable")) | Some lc0, Some lc1 -> - cassert (merge_funs <> None) meta "TODO: error message"; + sanity_check (merge_funs <> None) meta; merge_g_loan_contents lc0 lc1 | None, None -> craise meta "Unreachable" in @@ -2476,7 +2476,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end in (* Sanity check *) - if !Config.sanity_checks then sanity_check (abs_is_destructured meta true ctx abs) meta; + sanity_check (abs_is_destructured meta true ctx abs) meta; (* Return *) abs diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index d61e0bd1..1948c5a6 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -104,13 +104,13 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool (* Normalize the associated types *) match (ty1, ty2) with | TLiteral lit1, TLiteral lit2 -> - cassert (lit1 = lit2) meta "Tlitrals are not equal TODO: Error message"; + sanity_check (lit1 = lit2) meta; default | TAdt (id1, generics1), TAdt (id2, generics2) -> - cassert (id1 = id2) meta "ids are not equal TODO: Error message"; + sanity_check (id1 = id2) meta; (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) - cassert (generics1.const_generics = generics2.const_generics) meta "const generics are not the same"; + sanity_check (generics1.const_generics = generics2.const_generics) meta; (* We also ignore the trait refs *) @@ -152,12 +152,12 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool let tys_b = compare ty1 ty2 in combine regions_b tys_b | TVar id1, TVar id2 -> - cassert (id1 = id2) meta "Ids are not the same TODO: Error message"; + sanity_check (id1 = id2) meta; default | TTraitType _, TTraitType _ -> (* The types should have been normalized. If after normalization we get trait types, we can consider them as variables *) - cassert (ty1 = ty2) meta "The types are not normalized"; + sanity_check (ty1 = ty2) meta; default | _ -> log#lerror @@ -269,7 +269,7 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) super#visit_aloan_content env lc method! visit_EBinding env bv v = - cassert (Option.is_none !abs_or_var) meta "TODO : error message "; + sanity_check (Option.is_none !abs_or_var) meta; abs_or_var := Some (match bv with @@ -279,7 +279,7 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) abs_or_var := None method! visit_EAbs env abs = - cassert (Option.is_none !abs_or_var) meta "TODO : error message "; + sanity_check (Option.is_none !abs_or_var) meta; if ek.enter_abs then ( abs_or_var := Some (AbsId abs.abs_id); super#visit_EAbs env abs; @@ -320,7 +320,7 @@ let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nl * returning we check that we updated at least once. *) let r = ref false in let update () : loan_content = - cassert (not !r) meta "TODO : error message "; + sanity_check (not !r) meta; r := true; nlc in @@ -367,7 +367,7 @@ let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nl let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one loan *) - cassert !r meta "No loan was updated"; + sanity_check !r meta; ctx (** Update a abstraction loan content. @@ -383,7 +383,7 @@ let update_aloan (meta : Meta.meta ) (ek : exploration_kind) (l : BorrowId.id) ( * returning we check that we updated at least once. *) let r = ref false in let update () : aloan_content = - cassert (not !r) meta "TODO : error message "; + sanity_check (not !r) meta; r := true; nlc in @@ -416,7 +416,7 @@ let update_aloan (meta : Meta.meta ) (ek : exploration_kind) (l : BorrowId.id) ( let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one loan *) - cassert !r meta "No loan was uodated"; + sanity_check !r meta; ctx (** Lookup a borrow content from a borrow id. *) @@ -501,7 +501,7 @@ let update_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) * returning we check that we updated at least once. *) let r = ref false in let update () : borrow_content = - cassert (not !r) meta "TODO : error message "; + sanity_check (not !r) meta; r := true; nbc in @@ -542,7 +542,7 @@ let update_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one borrow *) - cassert !r meta "No borrow was updated"; + sanity_check !r meta; ctx (** Update an abstraction borrow content. @@ -558,7 +558,7 @@ let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) * returning we check that we updated at least once. *) let r = ref false in let update () : avalue = - cassert (not !r) meta "TODO: error message"; + sanity_check (not !r) meta; r := true; nv in @@ -881,7 +881,7 @@ let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) (regions : R update_non_shared regions sv ctx in (* Check that we updated at least once *) - cassert !updated meta "Not updated at least once"; + sanity_check !updated meta; (* Return *) ctx @@ -936,7 +936,7 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId. (subst : abs -> (msymbolic_value * aproj) list -> aproj) (ctx : eval_ctx) : eval_ctx = (* *) - cassert (ty_is_rty proj_ty) meta "proj_ty is not rty TODO: Error message"; + sanity_check (ty_is_rty proj_ty) meta; (* Small helpers for sanity checks *) let updated = ref false in let update abs local_given_back : aproj = @@ -958,7 +958,7 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId. | AProjLoans (sv', given_back) -> let abs = Option.get abs in if same_symbolic_id sv sv' then ( - cassert (sv.sv_ty = sv'.sv_ty) meta "TODO : error message "; + sanity_check (sv.sv_ty = sv'.sv_ty) meta; if projections_intersect meta proj_ty proj_regions sv'.sv_ty abs.regions then update abs given_back @@ -969,7 +969,7 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId. (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Check that we updated the context at least once *) - cassert !updated meta "Context was not updated at least once"; + sanity_check !updated meta; (* Return *) ctx @@ -989,7 +989,7 @@ let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb let found = ref None in let set_found x = (* There is at most one projector which corresponds to the description *) - cassert (Option.is_none !found) meta "More than one projecto corresponds to the description"; + sanity_check (Option.is_none !found) meta; found := Some x in (* The visitor *) @@ -1007,9 +1007,9 @@ let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb super#visit_aproj abs sproj | AProjLoans (sv', given_back) -> let abs = Option.get abs in - cassert (abs.abs_id = abs_id) meta "TODO : error message "; + sanity_check (abs.abs_id = abs_id) meta; if sv'.sv_id = sv.sv_id then ( - cassert (sv' = sv) meta "TODO : error message "; + sanity_check (sv' = sv) meta; set_found given_back) else ()); super#visit_aproj abs sproj @@ -1034,7 +1034,7 @@ let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb let found = ref false in let update () = (* We update at most once *) - cassert (not !found) meta "Updated more than once"; + sanity_check (not !found) meta; found := true; nproj in @@ -1053,9 +1053,9 @@ let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb super#visit_aproj abs sproj | AProjLoans (sv', _) -> let abs = Option.get abs in - cassert (abs.abs_id = abs_id) meta "TODO : error message "; + sanity_check (abs.abs_id = abs_id) meta; if sv'.sv_id = sv.sv_id then ( - cassert (sv' = sv) meta "TODO : error message "; + sanity_check (sv' = sv) meta; update ()) else super#visit_aproj (Some abs) sproj end @@ -1083,7 +1083,7 @@ let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : sy let found = ref false in let update () = (* We update at most once *) - cassert (not !found) meta "Updated more than once"; + sanity_check (not !found) meta; found := true; nproj in @@ -1102,9 +1102,9 @@ let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : sy super#visit_aproj abs sproj | AProjBorrows (sv', _proj_ty) -> let abs = Option.get abs in - cassert (abs.abs_id = abs_id) meta "TODO : error message "; + sanity_check (abs.abs_id = abs_id) meta; if sv'.sv_id = sv.sv_id then ( - cassert (sv' = sv) meta "TODO : error message "; + sanity_check (sv' = sv) meta; update ()) else super#visit_aproj (Some abs) sproj end diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 086c0786..a2550e88 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -66,7 +66,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (meta : Meta.me (** When visiting an abstraction, we remember the regions it owns to be able to properly reduce projectors when expanding symbolic values *) method! visit_abs current_abs abs = - cassert (Option.is_none current_abs) meta "TODO: error message"; + sanity_check (Option.is_none current_abs) meta; let current_abs = Some abs in super#visit_abs current_abs abs @@ -78,7 +78,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (meta : Meta.me method! visit_aproj current_abs aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - cassert (not (same_symbolic_id sv original_sv)) meta "TODO: error message" + sanity_check (not (same_symbolic_id sv original_sv)) meta | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj current_abs aproj @@ -98,7 +98,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (meta : Meta.me (* Check if this is the symbolic value we are looking for *) if same_symbolic_id sv original_sv then ( (* There mustn't be any given back values *) - cassert (given_back = []) meta "TODO: error message"; + sanity_check (given_back = []) meta; (* Apply the projector *) let projected_value = apply_proj_loans_on_symbolic_expansion meta proj_regions @@ -168,7 +168,7 @@ let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) (original_s (* Count *) let replaced = ref false in let replace () = - if at_most_once then cassert (not !replaced) meta "TODO: error message"; + if at_most_once then sanity_check (not !replaced) meta; replaced := true; nv in @@ -215,10 +215,10 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (expand_e (* Lookup the definition and check if it is an enumeration with several * variants *) let def = ctx_lookup_type_decl ctx def_id in - cassert (List.length generics.regions = List.length def.generics.regions) meta "TODO: error message"; + sanity_check (List.length generics.regions = List.length def.generics.regions) meta; (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = - AssociatedTypes.type_decl_get_inst_norm_variants_fields_rtypes ctx def + AssociatedTypes.type_decl_get_inst_norm_variants_fields_rtypes meta ctx def generics in (* Check if there is strictly more than one variant *) @@ -325,7 +325,7 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) else super#visit_VSymbolic env sv method! visit_EAbs proj_regions abs = - cassert (Option.is_none proj_regions) meta "TODO: error message"; + sanity_check (Option.is_none proj_regions) meta; let proj_regions = Some abs.regions in super#visit_EAbs proj_regions abs @@ -350,7 +350,7 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) method! visit_aproj proj_regions aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - cassert (not (same_symbolic_id sv original_sv)) meta "TODO: error message" + sanity_check (not (same_symbolic_id sv original_sv)) meta | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj proj_regions aproj @@ -376,7 +376,7 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) let ctx = obj#visit_eval_ctx None ctx in (* Finally, replace the projectors on loans *) let bids = !borrows in - cassert (not (BorrowId.Set.is_empty bids)) meta "TODO: error message"; + sanity_check (not (BorrowId.Set.is_empty bids)) meta; let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = @@ -394,9 +394,9 @@ let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) (region : region) (ref_ty : rty) (rkind : ref_kind) : cm_fun = fun cf ctx -> - cassert (region <> RErased) meta "TODO: error message"; + sanity_check (region <> RErased) meta; (* Check that we are allowed to expand the reference *) - cassert (not (region_in_set region ctx.ended_regions)) meta "TODO: error message"; + sanity_check (not (region_in_set region ctx.ended_regions)) meta; (* Match on the reference kind *) match rkind with | RMut -> @@ -446,7 +446,7 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Met (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = fun ctx -> - cassert (see_cf_l <> []) meta "TODO: error message"; + sanity_check (see_cf_l <> []) meta; (* Apply the symbolic expansion in the context and call the continuation *) let resl = List.map @@ -464,8 +464,8 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Met (lazy ("apply_branching_symbolic_expansions_non_borrow: " ^ symbolic_value_to_string ctx0 sv - ^ "\n\n- original context:\n" ^ eval_ctx_to_string meta ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); + ^ "\n\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* Continuation *) cf_br cf_after_join ctx) see_cf_l @@ -476,7 +476,7 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Met match resl with | Some _ :: _ -> Some (List.map Option.get resl) | None :: _ -> - List.iter (fun res -> cassert (res = None) meta "TODO: error message") resl; + List.iter (fun res -> sanity_check (res = None) meta) resl; None | _ -> craise meta "Unreachable" in @@ -492,7 +492,7 @@ let expand_symbolic_bool (config : config) (meta : Meta.meta) (sv : symbolic_val let original_sv = sv in let original_sv_place = sv_place in let rty = original_sv.sv_ty in - cassert (rty = TLiteral TBool) meta "TODO: error message"; + sanity_check (rty = TLiteral TBool) meta; (* Expand the symbolic value to true or false and continue execution *) let see_true = SeLiteral (VBool true) in let see_false = SeLiteral (VBool false) in @@ -554,8 +554,8 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv (lazy ("expand_symbolic_value_no_branching: " ^ symbolic_value_to_string ctx0 sv - ^ "\n\n- original context:\n" ^ eval_ctx_to_string meta ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); + ^ "\n\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* Sanity check: the symbolic value has disappeared *) sanity_check (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta) in diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 3922a3ab..7045d886 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -101,8 +101,8 @@ let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) | TChar, VChar v -> { value = VLiteral (VChar v); ty = TLiteral ty } | TInteger int_ty, VScalar v -> (* Check the type and the ranges *) - cassert (int_ty = v.int_ty) meta "Wrong type TODO: error message"; - cassert (check_scalar_value_in_range v) meta "Wrong range TODO: error message"; + sanity_check (int_ty = v.int_ty) meta; + sanity_check (check_scalar_value_in_range v) meta; { value = VLiteral (VScalar v); ty = TLiteral ty } (* Remaining cases (invalid) *) | _, _ -> craise meta "Improperly typed constant value" @@ -123,8 +123,8 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) log#ldebug (lazy ("copy_value: " - ^ typed_value_to_string meta ctx v - ^ "\n- context:\n" ^ eval_ctx_to_string meta ctx)); + ^ typed_value_to_string ~meta:(Some meta) ctx v + ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Remark: at some point we rewrote this function to use iterators, but then * we reverted the changes: the result was less clear actually. In particular, * the fact that we have exhaustive matches below makes very obvious the cases @@ -135,7 +135,7 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) (* Sanity check *) (match v.ty with | TAdt (TAssumed TBox, _) -> - craise meta "Can't copy an assumed value other than Option" + exec_raise meta "Can't copy an assumed value other than Option" | TAdt (TAdtId _, _) as ty -> sanity_check (allow_adt_copy || ty_is_primitively_copyable ty) meta | TAdt (TTuple, _) -> () (* Ok *) @@ -147,15 +147,15 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) const_generics = []; trait_refs = []; } ) -> - sanity_check (ty_is_primitively_copyable ty) meta - | _ -> craise meta "Unreachable"); + exec_assert (ty_is_primitively_copyable ty) meta "The type is not primitively copyable" + | _ -> exec_raise meta "Unreachable"); let ctx, fields = List.fold_left_map (copy_value meta allow_adt_copy config) ctx av.field_values in (ctx, { v with value = VAdt { av with field_values = fields } }) - | VBottom -> craise meta "Can't copy ⊥" + | VBottom -> exec_raise meta "Can't copy ⊥" | VBorrow bc -> ( (* We can only copy shared borrows *) match bc with @@ -165,13 +165,13 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) let bid' = fresh_borrow_id () in let ctx = InterpreterBorrows.reborrow_shared meta bid bid' ctx in (ctx, { v with value = VBorrow (VSharedBorrow bid') }) - | VMutBorrow (_, _) -> craise meta "Can't copy a mutable borrow" + | VMutBorrow (_, _) -> exec_raise meta "Can't copy a mutable borrow" | VReservedMutBorrow _ -> - craise meta "Can't copy a reserved mut borrow") + exec_raise meta "Can't copy a reserved mut borrow") | VLoan lc -> ( (* We can only copy shared loans *) match lc with - | VMutLoan _ -> craise meta "Can't copy a mutable loan" + | VMutLoan _ -> exec_raise meta "Can't copy a mutable loan" | VSharedLoan (_, sv) -> (* We don't copy the shared loan: only the shared value inside *) copy_value meta allow_adt_copy config ctx sv) @@ -256,7 +256,7 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan log#ldebug (lazy ("eval_operand_no_reorganize: op: " ^ operand_to_string ctx op - ^ "\n- ctx:\n" ^ eval_ctx_to_string meta ctx ^ "\n")); + ^ "\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* Evaluate *) match op with | Constant cv -> ( @@ -305,14 +305,14 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan let e = cf cv ctx in (* If we are synthesizing a symbolic AST, it means that we are in symbolic mode: the value of the const generic is necessarily symbolic. *) - cassert (e = None || is_symbolic cv.value) meta "The value of the const generic should be symbolic"; + sanity_check (e = None || is_symbolic cv.value) meta; (* We have to wrap the generated expression *) match e with | None -> None | Some e -> (* If we are synthesizing a symbolic AST, it means that we are in symbolic mode: the value of the const generic is necessarily symbolic. *) - cassert (is_symbolic cv.value) meta "The value of the const generic should be symbolic"; + sanity_check (is_symbolic cv.value) meta; (* *) Some (SymbolicAst.IntroSymbolic @@ -321,7 +321,7 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan value_as_symbolic meta cv.value, SymbolicAst.VaCgValue vid, e ))) - | CFnPtr _ -> craise meta "TODO") + | CFnPtr _ -> craise meta "TODO: error message") | Copy p -> (* Access the value *) let access = Read in @@ -330,7 +330,7 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan let copy cf v : m_fun = fun ctx -> (* Sanity checks *) - sanity_check (not (bottom_in_value ctx.ended_regions v)) meta; + exec_assert (not (bottom_in_value ctx.ended_regions v)) meta "Can not copy a value containing bottom"; sanity_check ( Option.is_none (find_first_primitively_copyable_sv_with_borrows @@ -351,7 +351,7 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan let move cf v : m_fun = fun ctx -> (* Check that there are no bottoms in the value we are about to move *) - cassert (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value we are about to move"; + exec_assert (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value we are about to move"; let bottom : typed_value = { value = VBottom; ty = v.ty } in let ctx = write_place meta access p bottom ctx in cf v ctx @@ -366,7 +366,7 @@ let eval_operand (config : config) (meta : Meta.meta) (op : operand) (cf : typed log#ldebug (lazy ("eval_operand: op: " ^ operand_to_string ctx op ^ "\n- ctx:\n" - ^ eval_ctx_to_string meta ctx ^ "\n")); + ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* We reorganize the context, then evaluate the operand *) comp (prepare_eval_operand_reorganize config meta op) @@ -421,7 +421,7 @@ let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) (o | ( Cast (CastScalar (TInteger src_ty, TInteger tgt_ty)), VLiteral (VScalar sv) ) -> ( (* Cast between integers *) - cassert (src_ty = sv.int_ty) meta "TODO: error message"; + sanity_check (src_ty = sv.int_ty) meta; let i = sv.value in match mk_scalar tgt_ty i with | Error _ -> cf (Error EPanic) @@ -443,12 +443,12 @@ let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) (o let b = if Z.of_int 0 = sv.value then false else if Z.of_int 1 = sv.value then true - else craise meta "Conversion from int to bool: out of range" + else exec_raise meta "Conversion from int to bool: out of range" in let value = VLiteral (VBool b) in let ty = TLiteral TBool in cf (Ok { ty; value }) - | _ -> craise meta "Invalid input for unop" + | _ -> exec_raise meta "Invalid input for unop" in comp eval_op apply cf @@ -466,7 +466,7 @@ let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) (o | Not, (TLiteral TBool as lty) -> lty | Neg, (TLiteral (TInteger _) as lty) -> lty | Cast (CastScalar (_, tgt_ty)), _ -> TLiteral tgt_ty - | _ -> craise meta "Invalid input for unop" + | _ -> exec_raise meta "Invalid input for unop" in let res_sv = { sv_id = res_sv_id; sv_ty = res_sv_ty } in (* Call the continuation *) @@ -494,9 +494,9 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typ * The remaining binops only operate on scalars. *) if binop = Eq || binop = Ne then ( (* Equality operations *) - cassert (v1.ty = v2.ty) meta "TODO: error message"; + exec_assert (v1.ty = v2.ty) meta "TODO: error message"; (* Equality/inequality check is primitive only for a subset of types *) - cassert (ty_is_primitively_copyable v1.ty) meta "Not primitively copyable TODO: error message"; + exec_assert (ty_is_primitively_copyable v1.ty) meta "Type is not primitively copyable"; let b = v1 = v2 in Ok { value = VLiteral (VBool b); ty = TLiteral TBool }) else @@ -511,7 +511,7 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typ match binop with | Lt | Le | Ge | Gt -> (* The two operands must have the same type and the result is a boolean *) - cassert (sv1.int_ty = sv2.int_ty) meta "The two operands must have the same type and the result is a boolean"; + sanity_check (sv1.int_ty = sv2.int_ty) meta; let b = match binop with | Lt -> Z.lt sv1.value sv2.value @@ -527,7 +527,7 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typ : typed_value) | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> ( (* The two operands must have the same type and the result is an integer *) - cassert (sv1.int_ty = sv2.int_ty) meta "The two operands must have the same type and the result is an integer"; + sanity_check (sv1.int_ty = sv2.int_ty) meta; let res = match binop with | Div -> @@ -583,9 +583,9 @@ let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) let res_sv_ty = if binop = Eq || binop = Ne then ( (* Equality operations *) - cassert (v1.ty = v2.ty) meta "TODO: error message"; + sanity_check (v1.ty = v2.ty) meta; (* Equality/inequality check is primitive only for a subset of types *) - cassert (ty_is_primitively_copyable v1.ty) meta "Not primitively copyable TODO: error message"; + exec_assert (ty_is_primitively_copyable v1.ty) meta "The type is not primitively copyable"; TLiteral TBool) else (* Other operations: input types are integers *) @@ -593,10 +593,10 @@ let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) | TLiteral (TInteger int_ty1), TLiteral (TInteger int_ty2) -> ( match binop with | Lt | Le | Ge | Gt -> - cassert (int_ty1 = int_ty2) meta "TODO: error message"; + sanity_check (int_ty1 = int_ty2) meta; TLiteral TBool | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> - cassert (int_ty1 = int_ty2) meta "TODO: error message"; + sanity_check (int_ty1 = int_ty2) meta; TLiteral (TInteger int_ty1) | Shl | Shr -> (* The number of bits can be of a different integer type @@ -632,7 +632,7 @@ let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) (bkind : bo In practice this restricted the behaviour too much, so for now we forbid them. *) - cassert (bkind <> BShallow) meta "Shallow borrow are currently forbidden"; + sanity_check (bkind <> BShallow) meta; (* Access the value *) let access = @@ -744,9 +744,9 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : AssociatedTypes.ctx_adt_get_inst_norm_field_etypes meta ctx def_id opt_variant_id generics in - cassert ( + sanity_check ( expected_field_types - = List.map (fun (v : typed_value) -> v.ty) values) meta "TODO: error message"; + = List.map (fun (v : typed_value) -> v.ty) values) meta; (* Construct the value *) let av : adt_value = { variant_id = opt_variant_id; field_values = values } @@ -815,7 +815,7 @@ let eval_fake_read (config : config) (meta : Meta.meta) (p : place) : cm_fun = in let cf_continue cf v : m_fun = fun ctx -> - cassert (not (bottom_in_value ctx.ended_regions v)) meta "TODO: error message"; + cassert (not (bottom_in_value ctx.ended_regions v)) meta "Fake read: the value contains bottom"; cf ctx in comp cf_prepare cf_continue cf ctx diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 4d4b709e..d2f1b5fb 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -68,7 +68,7 @@ let eval_loop_symbolic (config : config) (meta : meta) fun cf ctx -> (* Debug *) log#ldebug - (lazy ("eval_loop_symbolic:\nContext:\n" ^ eval_ctx_to_string meta ctx ^ "\n\n")); + (lazy ("eval_loop_symbolic:\nContext:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n")); (* Generate a fresh loop id *) let loop_id = fresh_loop_id () in @@ -81,8 +81,8 @@ let eval_loop_symbolic (config : config) (meta : meta) (* Debug *) log#ldebug (lazy - ("eval_loop_symbolic:\nInitial context:\n" ^ eval_ctx_to_string meta ctx - ^ "\n\nFixed point:\n" ^ eval_ctx_to_string meta fp_ctx)); + ("eval_loop_symbolic:\nInitial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\nFixed point:\n" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx)); (* Compute the loop input parameters *) let fresh_sids, input_svalues = compute_fp_ctx_symbolic_values meta ctx fp_ctx in @@ -122,8 +122,8 @@ let eval_loop_symbolic (config : config) (meta : meta) (lazy ("eval_loop_symbolic: about to match the fixed-point context with the \ original context:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string meta fp_ctx - ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string meta ctx)); + - src ctx (fixed-point ctx)" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx + ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); let end_expr : SymbolicAst.expression option = match_ctx_with_target config meta loop_id true fp_bl_corresp fp_input_svalues fixed_ids fp_ctx cf ctx @@ -155,8 +155,8 @@ let eval_loop_symbolic (config : config) (meta : meta) (lazy ("eval_loop_symbolic: about to match the fixed-point context \ with the context at a continue:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string meta fp_ctx - ^ "\n\n-tgt ctx (ctx at continue):\n" ^ eval_ctx_to_string meta ctx)); + - src ctx (fixed-point ctx)" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx + ^ "\n\n-tgt ctx (ctx at continue):\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); let cc = match_ctx_with_target config meta loop_id false fp_bl_corresp fp_input_svalues fixed_ids fp_ctx @@ -173,9 +173,9 @@ let eval_loop_symbolic (config : config) (meta : meta) log#ldebug (lazy ("eval_loop_symbolic: result:" ^ "\n- src context:\n" - ^ eval_ctx_to_string_no_filter meta ctx + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx ^ "\n- fixed point:\n" - ^ eval_ctx_to_string_no_filter meta fp_ctx + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) fp_ctx ^ "\n- fixed_sids: " ^ SymbolicValueId.Set.show fixed_ids.sids ^ "\n- fresh_sids: " @@ -209,7 +209,7 @@ let eval_loop_symbolic (config : config) (meta : meta) (fun (av : typed_avalue) -> match av.value with | ABorrow (AMutBorrow (bid, child_av)) -> - cassert (is_aignored child_av.value) meta "TODO: error message"; + sanity_check (is_aignored child_av.value) meta; Some (bid, child_av.ty) | ABorrow (ASharedBorrow _) -> None | _ -> craise meta "Unreachable") @@ -222,7 +222,7 @@ let eval_loop_symbolic (config : config) (meta : meta) (fun (av : typed_avalue) -> match av.value with | ALoan (AMutLoan (bid, child_av)) -> - cassert (is_aignored child_av.value) meta "TODO: error message"; + sanity_check (is_aignored child_av.value) meta; Some bid | ALoan (ASharedLoan _) -> None | _ -> craise meta "Unreachable") @@ -241,7 +241,7 @@ let eval_loop_symbolic (config : config) (meta : meta) ty) loan_ids in - cassert (BorrowId.Map.is_empty !borrows) meta "TODO: error message"; + sanity_check (BorrowId.Map.is_empty !borrows) meta; given_back_tys in diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 6ef4a13b..2de5aed0 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -53,16 +53,17 @@ type abs_borrows_loans_maps = { regions. *) module type PrimMatcher = sig - val match_etys : Meta.meta -> eval_ctx -> eval_ctx -> ety -> ety -> ety - val match_rtys : Meta.meta -> eval_ctx -> eval_ctx -> rty -> rty -> rty + val meta : Meta.meta + val match_etys : eval_ctx -> eval_ctx -> ety -> ety -> ety + val match_rtys : eval_ctx -> eval_ctx -> rty -> rty -> rty (** The input primitive values are not equal *) val match_distinct_literals : - Meta.meta -> eval_ctx -> eval_ctx -> ety -> literal -> literal -> typed_value + eval_ctx -> eval_ctx -> ety -> literal -> literal -> typed_value (** The input ADTs don't have the same variant *) val match_distinct_adts : - Meta.meta -> eval_ctx -> eval_ctx -> ety -> adt_value -> adt_value -> typed_value + eval_ctx -> eval_ctx -> ety -> adt_value -> adt_value -> typed_value (** The meta-value is the result of a match. @@ -75,7 +76,6 @@ module type PrimMatcher = sig calling the match function. *) val match_shared_borrows : - Meta.meta -> eval_ctx -> eval_ctx -> (typed_value -> typed_value -> typed_value) -> @@ -93,7 +93,6 @@ module type PrimMatcher = sig - [bv]: the result of matching [bv0] with [bv1] *) val match_mut_borrows : - Meta.meta -> eval_ctx -> eval_ctx -> ety -> @@ -111,7 +110,6 @@ module type PrimMatcher = sig [v]: the result of matching the shared values coming from the two loans *) val match_shared_loans : - Meta.meta -> eval_ctx -> eval_ctx -> ety -> @@ -125,7 +123,7 @@ module type PrimMatcher = sig (** There are no constraints on the input symbolic values *) val match_symbolic_values : - Meta.meta -> eval_ctx -> eval_ctx -> symbolic_value -> symbolic_value -> symbolic_value + eval_ctx -> eval_ctx -> symbolic_value -> symbolic_value -> symbolic_value (** Match a symbolic value with a value which is not symbolic. @@ -135,7 +133,7 @@ module type PrimMatcher = sig end loans in one of the two environments). *) val match_symbolic_with_other : - Meta.meta -> eval_ctx -> eval_ctx -> bool -> symbolic_value -> typed_value -> typed_value + eval_ctx -> eval_ctx -> bool -> symbolic_value -> typed_value -> typed_value (** Match a bottom value with a value which is not bottom. @@ -145,11 +143,10 @@ module type PrimMatcher = sig end loans in one of the two environments). *) val match_bottom_with_other : - Meta.meta -> eval_ctx -> eval_ctx -> bool -> typed_value -> typed_value + eval_ctx -> eval_ctx -> bool -> typed_value -> typed_value (** The input ADTs don't have the same variant *) val match_distinct_aadts : - Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -167,7 +164,6 @@ module type PrimMatcher = sig [ty]: result of matching ty0 and ty1 *) val match_ashared_borrows : - Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -188,7 +184,6 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_amut_borrows : - Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -215,7 +210,6 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_ashared_loans : - Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -242,7 +236,6 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_amut_loans : - Meta.meta -> eval_ctx -> eval_ctx -> rty -> @@ -259,7 +252,7 @@ module type PrimMatcher = sig is typically used to raise the proper exception). *) val match_avalues : - Meta.meta -> eval_ctx -> eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue + eval_ctx -> eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue end module type Matcher = sig @@ -267,15 +260,16 @@ module type Matcher = sig Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) + val meta : Meta.meta val match_typed_values : - Meta.meta -> eval_ctx -> eval_ctx -> typed_value -> typed_value -> typed_value + eval_ctx -> eval_ctx -> typed_value -> typed_value -> typed_value (** Match two avalues. Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) val match_typed_avalues : - Meta.meta -> eval_ctx -> eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue + eval_ctx -> eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue end (** See {!module:InterpreterLoopsMatchCtxs.MakeCheckEquivMatcher} and @@ -304,6 +298,7 @@ module type MatchCheckEquivState = sig val aid_map : AbstractionId.InjSubst.t ref val lookup_shared_value_in_ctx0 : BorrowId.id -> typed_value val lookup_shared_value_in_ctx1 : BorrowId.id -> typed_value + val meta : Meta.meta end module type CheckEquivMatcher = sig @@ -353,6 +348,7 @@ module type MatchJoinState = sig (** The abstractions introduced when performing the matches *) val nabs : abs list ref + val meta : Meta.meta end (** Split an environment between the fixed abstractions, values, etc. and diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 44b9a44e..f6ce9b32 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -272,7 +272,7 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f sanity_check (RegionId.Set.is_empty abs.ancestors_regions) meta; (* Introduce the new abstraction for the shared values *) - cassert (ty_no_regions sv.ty) meta "TODO : error message "; + cassert (ty_no_regions sv.ty) meta "Nested borrows are not supported yet"; let rty = sv.ty in (* Create the shared loan child *) @@ -461,9 +461,9 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id (lazy ("compute_loop_entry_fixed_point: after prepare_ashared_loans:" ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter meta ctx0 + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx0 ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter meta ctx + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx ^ "\n\n")); let cf_exit_loop_body (res : statement_eval_res) : m_fun = @@ -597,9 +597,9 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id log#ldebug (lazy ("compute_fixed_point:" ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter meta ctx + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter meta ctx1 + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx1 ^ "\n\n")); (* Check if we reached a fixed point: if not, iterate *) @@ -612,7 +612,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id (lazy ("compute_fixed_point: fixed point computed before matching with input \ region groups:" ^ "\n\n- fp:\n" - ^ eval_ctx_to_string_no_filter meta fp + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) fp ^ "\n\n")); (* Make sure we have exactly one loop abstraction per function region (merge @@ -634,10 +634,10 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> - cassert (loop_id' = loop_id) meta "TODO : error message "; - cassert (kind = LoopSynthInput) meta "TODO : error message "; + sanity_check (loop_id' = loop_id) meta; + sanity_check (kind = LoopSynthInput) meta; (* The abstractions introduced so far should be endable *) - cassert (abs.can_end = true) meta "The abstractions introduced so far can not end"; + sanity_check (abs.can_end = true) meta; add_aid abs.abs_id; abs | _ -> abs @@ -694,9 +694,9 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id in (* By default, the [SynthInput] abs can't end *) let ctx = ctx_set_abs_can_end meta ctx abs_id true in - cassert ( + sanity_check ( let abs = ctx_lookup_abs ctx abs_id in - abs.kind = SynthInput rg_id) meta "TODO : error message "; + abs.kind = SynthInput rg_id) meta; (* End this abstraction *) let ctx = InterpreterBorrows.end_abstraction_no_synth config meta abs_id ctx @@ -725,7 +725,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id (* We also check that all the regions need to end - this is not necessary per se, but if it doesn't happen it is bizarre and worth investigating... *) - cassert (AbstractionId.Set.equal !aids_union !fp_aids) meta "Not all regions need to end TODO: Error message"; + sanity_check (AbstractionId.Set.equal !aids_union !fp_aids) meta; (* Merge the abstractions which need to be merged, and compute the map from region id to abstraction id *) @@ -815,8 +815,8 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> - cassert (loop_id' = loop_id) meta "TODO : error message "; - cassert (kind = LoopSynthInput) meta "TODO : error message "; + sanity_check (loop_id' = loop_id) meta; + sanity_check (kind = LoopSynthInput) meta; let kind : abs_kind = if remove_rg_id then Loop (loop_id, None, LoopSynthInput) else abs.kind @@ -838,7 +838,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id (lazy ("compute_fixed_point: fixed point after matching with the function \ region groups:\n" - ^ eval_ctx_to_string_no_filter meta fp_test)); + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) fp_test)); compute_fixed_point fp_test 1 1 in @@ -855,8 +855,8 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se log#ldebug (lazy ("compute_fixed_point_id_correspondance:\n\n- fixed_ids:\n" - ^ show_ids_sets fixed_ids ^ "\n\n- src_ctx:\n" ^ eval_ctx_to_string meta src_ctx - ^ "\n\n- tgt_ctx:\n" ^ eval_ctx_to_string meta tgt_ctx ^ "\n\n")); + ^ show_ids_sets fixed_ids ^ "\n\n- src_ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n\n- tgt_ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx ^ "\n\n")); let filt_src_env, _, _ = ctx_split_fixed_new meta fixed_ids src_ctx in let filt_src_ctx = { src_ctx with env = filt_src_env } in @@ -867,9 +867,9 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se (lazy ("compute_fixed_point_id_correspondance:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- filt_src_ctx:\n" - ^ eval_ctx_to_string meta filt_src_ctx + ^ eval_ctx_to_string ~meta:(Some meta) filt_src_ctx ^ "\n\n- filt_tgt_ctx:\n" - ^ eval_ctx_to_string meta filt_tgt_ctx + ^ eval_ctx_to_string ~meta:(Some meta) filt_tgt_ctx ^ "\n\n")); (* Match the source context and the filtered target context *) @@ -941,7 +941,7 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se ids.loan_ids in (* Check that the loan and borrows are related *) - cassert (BorrowId.Set.equal ids.borrow_ids loan_ids) meta "The loan and borrows are not related") + sanity_check (BorrowId.Set.equal ids.borrow_ids loan_ids) meta) new_absl; (* For every target abstraction (going back to the [list_nth_mut] example, @@ -1089,9 +1089,9 @@ let compute_fp_ctx_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) (fp_ctx : log#ldebug (lazy ("compute_fp_ctx_symbolic_values:" ^ "\n- src context:\n" - ^ eval_ctx_to_string_no_filter meta ctx + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx ^ "\n- fixed point:\n" - ^ eval_ctx_to_string_no_filter meta fp_ctx + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) fp_ctx ^ "\n- fresh_sids: " ^ SymbolicValueId.Set.show fresh_sids ^ "\n- input_svalues: " diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 74d31975..8153ef08 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -136,7 +136,7 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids - ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string meta ctx0 ^ "\n\n")); + ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n")); let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in @@ -171,13 +171,13 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx: after converting values to abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string meta ctx ^ "\n\n" + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n" )); log#ldebug (lazy ("collapse_ctx: after decomposing the shared values in the abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string meta ctx ^ "\n\n" + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n" )); (* Explore all the *new* abstractions, and compute various maps *) @@ -252,7 +252,7 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) ^ AbstractionId.to_string abs_id1 ^ " into " ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" ^ eval_ctx_to_string meta !ctx)); + ^ ":\n\n" ^ eval_ctx_to_string ~meta:(Some meta) !ctx)); (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) @@ -272,7 +272,7 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids - ^ "\n\n- after collapse:\n" ^ eval_ctx_to_string meta !ctx ^ "\n\n")); + ^ "\n\n- after collapse:\n" ^ eval_ctx_to_string ~meta:(Some meta) !ctx ^ "\n\n")); (* Reorder the loans and borrows in the fresh abstractions *) let ctx = reorder_loans_borrows_in_fresh_abs meta old_ids.aids !ctx in @@ -281,7 +281,7 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- after collapse and reorder borrows/loans:\n" - ^ eval_ctx_to_string meta ctx ^ "\n\n")); + ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n")); (* Return the new context *) ctx @@ -290,6 +290,7 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id : merge_duplicates_funcs = (* Rem.: the merge functions raise exceptions (that we catch). *) let module S : MatchJoinState = struct + let meta = meta let loop_id = loop_id let nabs = ref [] end in @@ -356,11 +357,11 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id This time we need to also merge the shared values. We rely on the join matcher [JM] to do so. *) - cassert (not (value_has_loans_or_borrows ctx sv0.value)) meta "TODO: error message"; - cassert (not (value_has_loans_or_borrows ctx sv1.value)) meta "TODO: error message"; + sanity_check (not (value_has_loans_or_borrows ctx sv0.value)) meta; + sanity_check (not (value_has_loans_or_borrows ctx sv1.value)) meta; let ty = ty0 in let child = child0 in - let sv = M.match_typed_values meta ctx ctx sv0 sv1 in + let sv = M.match_typed_values ctx ctx sv0 sv1 in let value = ALoan (ASharedLoan (ids, sv, child)) in { value; ty } in @@ -397,9 +398,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (lazy ("join_ctxs:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter meta ctx0 + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx0 ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter meta ctx1 + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx1 ^ "\n\n")); let env0 = List.rev ctx0.env in @@ -413,9 +414,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (lazy ("join_suffixes:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter meta { ctx0 with env = List.rev env0 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter meta { ctx1 with env = List.rev env1 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx1 with env = List.rev env1 } ^ "\n\n")); (* Sanity check: there are no values/abstractions which should be in the prefix *) @@ -441,6 +442,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c in let module S : MatchJoinState = struct + let meta = meta let loop_id = loop_id let nabs = nabs end in @@ -468,7 +470,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (* Still in the prefix: match the values *) cassert (b0 = b1) meta "Bindings are not the same. We are not in the prefix anymore"; let b = b0 in - let v = M.match_typed_values meta ctx0 ctx1 v0 v1 in + let v = M.match_typed_values ctx0 ctx1 v0 v1 in let var = EBinding (BDummy b, v) in (* Continue *) var :: join_prefixes env0' env1') @@ -492,7 +494,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c ids must be the same"; (* Match the values *) let b = b0 in - let v = M.match_typed_values meta ctx0 ctx1 v0 v1 in + let v = M.match_typed_values ctx0 ctx1 v0 v1 in let var = EBinding (BVar b, v) in (* Continue *) var :: join_prefixes env0' env1' @@ -669,21 +671,21 @@ let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: initial ctx:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Destructure the abstractions introduced in the new context *) let ctx = destructure_new_abs meta loop_id fixed_ids.aids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after destructure:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Collapse the context we want to add to the join *) let ctx = collapse_ctx meta loop_id None fixed_ids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after collapse:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Refresh the fresh abstractions *) let ctx = refresh_abs fixed_ids.aids ctx in @@ -693,7 +695,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after join:\n" - ^ eval_ctx_to_string meta ctx1)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx1)); (* Collapse again - the join might have introduce abstractions we want to merge with the others (note that those abstractions may actually @@ -702,7 +704,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after join-collapse:\n" - ^ eval_ctx_to_string meta !joined_ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) !joined_ctx)); (* Sanity check *) if !Config.sanity_checks then Invariants.check_invariants meta !joined_ctx; diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 435174a7..c02d3117 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -149,9 +149,9 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) let match_rec = match_types meta match_distinct_types match_regions in match (ty0, ty1) with | TAdt (id0, generics0), TAdt (id1, generics1) -> - cassert (id0 = id1) meta "TODO: error message"; - cassert (generics0.const_generics = generics1.const_generics) meta "TODO: error message"; - cassert (generics0.trait_refs = generics1.trait_refs) meta "TODO: error message"; + sanity_check (id0 = id1) meta; + sanity_check (generics0.const_generics = generics1.const_generics) meta; + sanity_check (generics0.trait_refs = generics1.trait_refs) meta; let id = id0 in let const_generics = generics1.const_generics in let trait_refs = generics1.trait_refs in @@ -168,27 +168,28 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) let generics = { regions; types; const_generics; trait_refs } in TAdt (id, generics) | TVar vid0, TVar vid1 -> - cassert (vid0 = vid1) meta "TODO: error message"; + sanity_check (vid0 = vid1) meta; let vid = vid0 in TVar vid | TLiteral lty0, TLiteral lty1 -> - cassert (lty0 = lty1) meta "TODO: error message"; + sanity_check (lty0 = lty1) meta; ty0 | TNever, TNever -> ty0 | TRef (r0, ty0, k0), TRef (r1, ty1, k1) -> let r = match_regions r0 r1 in let ty = match_rec ty0 ty1 in - cassert (k0 = k1) meta "TODO: error message"; + sanity_check (k0 = k1) meta; let k = k0 in TRef (r, ty, k) | _ -> match_distinct_types ty0 ty1 module MakeMatcher (M : PrimMatcher) : Matcher = struct - let rec match_typed_values (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let meta = M.meta + let rec match_typed_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) (v0 : typed_value) (v1 : typed_value) : typed_value = - let match_rec = match_typed_values meta ctx0 ctx1 in - let ty = M.match_etys meta ctx0 ctx1 v0.ty v1.ty in - (* Using ValuesUtils.value_has_borrows on purpose here: we want + let match_rec = match_typed_values ctx0 ctx1 in + let ty = M.match_etys ctx0 ctx1 v0.ty v1.ty in + (* Using ValuesUtils.value_ has_borrows on purpose here: we want to make explicit the fact that, though we have to pick one of the two contexts (ctx0 here) to call value_has_borrows, it doesn't matter here. *) @@ -197,7 +198,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct in match (v0.value, v1.value) with | VLiteral lv0, VLiteral lv1 -> - if lv0 = lv1 then v1 else M.match_distinct_literals meta ctx0 ctx1 ty lv0 lv1 + if lv0 = lv1 then v1 else M.match_distinct_literals ctx0 ctx1 ty lv0 lv1 | VAdt av0, VAdt av1 -> if av0.variant_id = av1.variant_id then let fields = List.combine av0.field_values av1.field_values in @@ -210,17 +211,17 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct { value; ty = v1.ty } else ( (* For now, we don't merge ADTs which contain borrows *) - cassert (not (value_has_borrows v0.value)) meta "ADTs which contain borrows are not merged yet"; - cassert (not (value_has_borrows v1.value)) meta "ADTs which contain borrows are not merged yet"; + sanity_check (not (value_has_borrows v0.value)) M.meta; + sanity_check (not (value_has_borrows v1.value)) M.meta; (* Merge *) - M.match_distinct_adts meta ctx0 ctx1 ty av0 av1) + M.match_distinct_adts ctx0 ctx1 ty av0 av1) | VBottom, VBottom -> v0 | VBorrow bc0, VBorrow bc1 -> let bc = match (bc0, bc1) with | VSharedBorrow bid0, VSharedBorrow bid1 -> let bid = - M.match_shared_borrows meta ctx0 ctx1 match_rec ty bid0 bid1 + M.match_shared_borrows ctx0 ctx1 match_rec ty bid0 bid1 in VSharedBorrow bid | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> @@ -229,9 +230,9 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct cassert ( not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos - bv.value)) meta "TODO: error message"; + bv.value)) M.meta "TODO: error message"; let bid, bv = - M.match_mut_borrows meta ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv + M.match_mut_borrows ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv in VMutBorrow (bid, bv) | VReservedMutBorrow _, _ @@ -242,7 +243,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct trying to match a reserved borrow, which shouldn't happen because reserved borrow should be eliminated very quickly - they are introduced just before function calls which activate them *) - craise meta "Unexpected" + craise M.meta "Unexpected" in { value = VBorrow bc; ty } | VLoan lc0, VLoan lc1 -> @@ -252,23 +253,23 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (lc0, lc1) with | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in - cassert (not (value_has_borrows sv.value)) meta "TODO: error message"; - let ids, sv = M.match_shared_loans meta ctx0 ctx1 ty ids0 ids1 sv in + cassert (not (value_has_borrows sv.value)) M.meta "TODO: error message"; + let ids, sv = M.match_shared_loans ctx0 ctx1 ty ids0 ids1 sv in VSharedLoan (ids, sv) | VMutLoan id0, VMutLoan id1 -> let id = M.match_mut_loans ctx0 ctx1 ty id0 id1 in VMutLoan id | VSharedLoan _, VMutLoan _ | VMutLoan _, VSharedLoan _ -> - craise meta "Unreachable" + craise M.meta "Unreachable" in { value = VLoan lc; ty = v1.ty } | VSymbolic sv0, VSymbolic sv1 -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - cassert (not (value_has_borrows v0.value)) meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; - cassert (not (value_has_borrows v1.value)) meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; + cassert (not (value_has_borrows v0.value)) M.meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; + cassert (not (value_has_borrows v1.value)) M.meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; (* Match *) - let sv = M.match_symbolic_values meta ctx0 ctx1 sv0 sv1 in + let sv = M.match_symbolic_values ctx0 ctx1 sv0 sv1 in { v1 with value = VSymbolic sv } | VLoan lc, _ -> ( match lc with @@ -278,27 +279,27 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match lc with | VSharedLoan (ids, _) -> raise (ValueMatchFailure (LoansInRight ids)) | VMutLoan id -> raise (ValueMatchFailure (LoanInRight id))) - | VSymbolic sv, _ -> M.match_symbolic_with_other meta ctx0 ctx1 true sv v1 - | _, VSymbolic sv -> M.match_symbolic_with_other meta ctx0 ctx1 false sv v0 - | VBottom, _ -> M.match_bottom_with_other meta ctx0 ctx1 true v1 - | _, VBottom -> M.match_bottom_with_other meta ctx0 ctx1 false v0 + | VSymbolic sv, _ -> M.match_symbolic_with_other ctx0 ctx1 true sv v1 + | _, VSymbolic sv -> M.match_symbolic_with_other ctx0 ctx1 false sv v0 + | VBottom, _ -> M.match_bottom_with_other ctx0 ctx1 true v1 + | _, VBottom -> M.match_bottom_with_other ctx0 ctx1 false v0 | _ -> log#ldebug (lazy ("Unexpected match case:\n- value0: " - ^ typed_value_to_string meta ctx0 v0 + ^ typed_value_to_string ~meta:(Some M.meta) ctx0 v0 ^ "\n- value1: " - ^ typed_value_to_string meta ctx1 v1)); - craise meta "Unexpected match case" + ^ typed_value_to_string ~meta:(Some M.meta) ctx1 v1)); + craise M.meta "Unexpected match case" - and match_typed_avalues (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) + and match_typed_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) (v0 : typed_avalue) (v1 : typed_avalue) : typed_avalue = log#ldebug (lazy ("match_typed_avalues:\n- value0: " - ^ typed_avalue_to_string meta ctx0 v0 + ^ typed_avalue_to_string ~meta:(Some M.meta) ctx0 v0 ^ "\n- value1: " - ^ typed_avalue_to_string meta ctx1 v1)); + ^ typed_avalue_to_string ~meta:(Some M.meta) ctx1 v1)); (* Using ValuesUtils.value_has_borrows on purpose here: we want to make explicit the fact that, though we have to pick @@ -308,9 +309,9 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos in - let match_rec = match_typed_values meta ctx0 ctx1 in - let match_arec = match_typed_avalues meta ctx0 ctx1 in - let ty = M.match_rtys meta ctx0 ctx1 v0.ty v1.ty in + let match_rec = match_typed_values ctx0 ctx1 in + let match_arec = match_typed_avalues ctx0 ctx1 in + let ty = M.match_rtys ctx0 ctx1 v0.ty v1.ty in match (v0.value, v1.value) with | AAdt av0, AAdt av1 -> if av0.variant_id = av1.variant_id then @@ -323,15 +324,15 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct in { value; ty } else (* Merge *) - M.match_distinct_aadts meta ctx0 ctx1 v0.ty av0 v1.ty av1 ty - | ABottom, ABottom -> mk_abottom meta ty - | AIgnored, AIgnored -> mk_aignored meta ty + M.match_distinct_aadts ctx0 ctx1 v0.ty av0 v1.ty av1 ty + | ABottom, ABottom -> mk_abottom M.meta ty + | AIgnored, AIgnored -> mk_aignored M.meta ty | ABorrow bc0, ABorrow bc1 -> ( log#ldebug (lazy "match_typed_avalues: borrows"); match (bc0, bc1) with | ASharedBorrow bid0, ASharedBorrow bid1 -> log#ldebug (lazy "match_typed_avalues: shared borrows"); - M.match_ashared_borrows meta ctx0 ctx1 v0.ty bid0 v1.ty bid1 ty + M.match_ashared_borrows ctx0 ctx1 v0.ty bid0 v1.ty bid1 ty | AMutBorrow (bid0, av0), AMutBorrow (bid1, av1) -> log#ldebug (lazy "match_typed_avalues: mut borrows"); log#ldebug @@ -340,10 +341,10 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut borrows: matched children values"); - M.match_amut_borrows meta ctx0 ctx1 v0.ty bid0 av0 v1.ty bid1 av1 ty av + M.match_amut_borrows ctx0 ctx1 v0.ty bid0 av0 v1.ty bid1 av1 ty av | AIgnoredMutBorrow _, AIgnoredMutBorrow _ -> (* The abstractions are destructured: we shouldn't get there *) - craise meta "Unexpected" + craise M.meta "Unexpected" | AProjSharedBorrow asb0, AProjSharedBorrow asb1 -> ( match (asb0, asb1) with | [], [] -> @@ -352,7 +353,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct v0 | _ -> (* We should get there only if there are nested borrows *) - craise meta "Unexpected") + craise M.meta "Unexpected") | _ -> (* TODO: getting there is not necessarily inconsistent (it may just be because the environments don't match) so we may want @@ -363,7 +364,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct we are *currently* ending it, in which case we need to completely end it before continuing. *) - craise meta "Unexpected") + craise M.meta "Unexpected") | ALoan lc0, ALoan lc1 -> ( log#ldebug (lazy "match_typed_avalues: loans"); (* TODO: maybe we should enforce that the ids are always exactly the same - @@ -373,8 +374,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct log#ldebug (lazy "match_typed_avalues: shared loans"); let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in - cassert (not (value_has_borrows sv.value)) meta "TODO: error message"; - M.match_ashared_loans meta ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 + sanity_check (not (value_has_borrows sv.value)) M.meta; + M.match_ashared_loans ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 av1 ty sv av | AMutLoan (id0, av0), AMutLoan (id1, av1) -> log#ldebug (lazy "match_typed_avalues: mut loans"); @@ -383,48 +384,49 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut loans: matched children values"); - M.match_amut_loans meta ctx0 ctx1 v0.ty id0 av0 v1.ty id1 av1 ty av + M.match_amut_loans ctx0 ctx1 v0.ty id0 av0 v1.ty id1 av1 ty av | AIgnoredMutLoan _, AIgnoredMutLoan _ | AIgnoredSharedLoan _, AIgnoredSharedLoan _ -> (* Those should have been filtered when destructuring the abstractions - they are necessary only when there are nested borrows *) - craise meta "Unreachable" - | _ -> craise meta "Unreachable") + craise M.meta "Unreachable" + | _ -> craise M.meta "Unreachable") | ASymbolic _, ASymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - craise meta "Unreachable" - | _ -> M.match_avalues meta ctx0 ctx1 v0 v1 + craise M.meta "Unreachable" + | _ -> M.match_avalues ctx0 ctx1 v0 v1 end module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (** Small utility *) + let meta = S.meta let push_abs (abs : abs) : unit = S.nabs := abs :: !S.nabs let push_absl (absl : abs list) : unit = List.iter push_abs absl - let match_etys (meta : Meta.meta) _ _ ty0 ty1 = - cassert (ty0 = ty1) meta "TODO: error message"; + let match_etys _ _ ty0 ty1 = + sanity_check (ty0 = ty1) meta; ty0 - let match_rtys (meta : Meta.meta) _ _ ty0 ty1 = + let match_rtys _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) - cassert (ty0 = ty1) meta "The types must be equal - in effect, this forbids to match symbolic values containing borrows"; + sanity_check (ty0 = ty1) meta; ty0 - let match_distinct_literals (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_distinct_adts (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (ty : ety) + let match_distinct_adts (ctx0 : eval_ctx) (ctx1 : eval_ctx) (ty : ety) (adt0 : adt_value) (adt1 : adt_value) : typed_value = (* Check that the ADTs don't contain borrows - this is redundant with checks performed by the caller, but we prefer to be safe with regards to future updates *) let check_no_borrows ctx (v : typed_value) = - cassert (not (value_has_borrows ctx v.value)) meta "ADTs should not contain borrows" + sanity_check (not (value_has_borrows ctx v.value)) meta in List.iter (check_no_borrows ctx0) adt0.field_values; List.iter (check_no_borrows ctx1) adt1.field_values; @@ -452,7 +454,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* No borrows, no loans, no bottoms: we can introduce a symbolic value *) mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_shared_borrows (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) match_rec + let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) match_rec (ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = (* Lookup the shared values and match them - we do this mostly to make sure we end loans which might appear on one side @@ -508,7 +510,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) bid2 - let match_mut_borrows (meta : Meta.meta) (ctx0 : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_mut_borrows (ctx0 : eval_ctx) (_ : eval_ctx) (ty : ety) (bid0 : borrow_id) (bv0 : typed_value) (bid1 : borrow_id) (bv1 : typed_value) (bv : typed_value) : borrow_id * typed_value = if bid0 = bid1 then ( @@ -560,10 +562,10 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct will update [v], while the backward loop function will return nothing. *) cassert ( - not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) meta "TODO: error message"; + not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) meta "Nested borrows are not supported yet"; if bv0 = bv1 then ( - cassert (bv0 = bv) meta "TODO: error message"; + sanity_check (bv0 = bv) meta; (bid0, bv)) else let rid = fresh_region_id () in @@ -571,7 +573,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let kind = RMut in let bv_ty = bv.ty in - cassert (ty_no_regions bv_ty) meta "TODO: error message"; + sanity_check (ty_no_regions bv_ty) meta; let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in let borrow_av = @@ -624,7 +626,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = let bv_ty = bv.ty in - cassert (ty_no_regions bv_ty) meta "TODO: error message"; + cassert (ty_no_regions bv_ty) meta "Nested borrows are not supported yet"; let value = ABorrow (AMutBorrow (bid, mk_aignored meta bv_ty)) in { value; ty = borrow_ty } in @@ -654,7 +656,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) (bid2, sv) - let match_shared_loans (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : ety) + let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) (sv : typed_value) : loan_id_set * typed_value = (* Check if the ids are the same - Rem.: we forbid the sets of loans @@ -671,7 +673,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct raise (ValueMatchFailure (LoansInRight extra_ids_right)); (* This should always be true if we get here *) - cassert (ids0 = ids1) meta "This should always be true if we get here "; + sanity_check (ids0 = ids1) meta; let ids = ids0 in (* Return *) @@ -685,7 +687,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct both borrows *) raise (ValueMatchFailure (LoanInLeft id0)) - let match_symbolic_values (meta : Meta.meta) (ctx0 : eval_ctx) (_ : eval_ctx) + let match_symbolic_values (ctx0 : eval_ctx) (_ : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -697,11 +699,11 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct else ( (* The caller should have checked that the symbolic values don't contain borrows *) - cassert (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)) meta "The caller should have checked that the symbolic values don't contain borrows"; + sanity_check (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)) meta; (* We simply introduce a fresh symbolic value *) mk_fresh_symbolic_value meta sv0.sv_ty) - let match_symbolic_with_other (meta : Meta.meta) (ctx0 : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (ctx0 : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = (* Check that: - there are no borrows in the symbolic value @@ -729,7 +731,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return a fresh symbolic value *) mk_fresh_symbolic_typed_value meta sv.sv_ty - let match_bottom_with_other (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) + let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) (v : typed_value) : typed_value = (* If there are outer loans in the non-bottom value, raise an exception. Otherwise, convert it to an abstraction and return [Bottom]. @@ -770,15 +772,15 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) - let match_distinct_aadts (meta : Meta.meta) _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_borrows (meta : Meta.meta) _ _ _ _ _ _ = craise meta "Unreachable" - let match_amut_borrows (meta : Meta.meta) _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_distinct_aadts _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_ashared_borrows _ _ _ _ _ _ = craise meta "Unreachable" + let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_loans (meta: Meta.meta) _ _ _ _ _ _ _ _ _ _ _ _ _ = + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_amut_loans (meta: Meta.meta) _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_avalues (meta: Meta.meta) _ _ _ _ = craise meta "Unreachable" + let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_avalues _ _ _ _ = craise meta "Unreachable" end (* Very annoying: functors only take modules as inputs... *) @@ -788,6 +790,7 @@ module type MatchMoveState = sig (** The moved values *) val nvalues : typed_value list ref + val meta : Meta.meta end (* We use this matcher to move values in environment. @@ -808,40 +811,41 @@ end *) module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (** Small utility *) + let meta = S.meta let push_moved_value (v : typed_value) : unit = S.nvalues := v :: !S.nvalues - let match_etys (meta : Meta.meta) _ _ ty0 ty1 = - cassert (ty0 = ty1) meta "TODO: error message"; + let match_etys _ _ ty0 ty1 = + sanity_check (ty0 = ty1) meta; ty0 - let match_rtys (meta : Meta.meta) _ _ ty0 ty1 = + let match_rtys _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) - cassert (ty0 = ty1) meta "The types must be equal - in effect, this forbids to match symbolic values containing borrows"; + sanity_check (ty0 = ty1) meta; ty0 - let match_distinct_literals (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (l : literal) : typed_value = { value = VLiteral l; ty } - let match_distinct_adts (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_adts (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : adt_value) (adt1 : adt_value) : typed_value = (* Note that if there was a bottom inside the ADT on the left, the value on the left should have been simplified to bottom. *) { ty; value = VAdt adt1 } - let match_shared_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) _ (_ : ety) + let match_shared_borrows (_ : eval_ctx) (_ : eval_ctx) _ (_ : ety) (_ : borrow_id) (bid1 : borrow_id) : borrow_id = (* There can't be bottoms in shared values *) bid1 - let match_mut_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (_ : borrow_id) + let match_mut_borrows (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (_ : borrow_id) (_ : typed_value) (bid1 : borrow_id) (bv1 : typed_value) (_ : typed_value) : borrow_id * typed_value = (* There can't be bottoms in borrowed values *) (bid1, bv1) - let match_shared_loans (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : ety) + let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (_ : loan_id_set) (ids1 : loan_id_set) (sv : typed_value) : loan_id_set * typed_value = (* There can't be bottoms in shared loans *) @@ -851,15 +855,15 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (id1 : loan_id) : loan_id = id1 - let match_symbolic_values (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : symbolic_value) + let match_symbolic_values (_ : eval_ctx) (_ : eval_ctx) (_ : symbolic_value) (sv1 : symbolic_value) : symbolic_value = sv1 - let match_symbolic_with_other (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = if left then v else mk_typed_value_from_symbolic_value sv - let match_bottom_with_other (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_bottom_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) (v : typed_value) : typed_value = let with_borrows = false in if left then ( @@ -891,22 +895,21 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) - let match_distinct_aadts (meta : Meta.meta) _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_borrows (meta : Meta.meta) _ _ _ _ _ _ = craise meta "Unreachable" - let match_amut_borrows (meta : Meta.meta) _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_distinct_aadts _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_ashared_borrows _ _ _ _ _ _ = craise meta "Unreachable" + let match_amut_borrows _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_loans (meta : Meta.meta) _ _ _ _ _ _ _ _ _ _ _ _ _ = + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_amut_loans (meta : Meta.meta) _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_avalues (meta : Meta.meta) _ _ _ _ = craise meta "Unreachable" + let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_avalues _ _ _ _ = craise meta "Unreachable" end module MakeCheckEquivMatcher (S : MatchCheckEquivState) : CheckEquivMatcher = struct module MkGetSetM (Id : Identifiers.Id) = struct module Inj = Id.InjSubst - let add (msg : string) (m : Inj.t ref) (k0 : Id.id) (k1 : Id.id) = (* Check if k0 is already registered as a key *) match Inj.find_opt k0 !m with @@ -945,7 +948,7 @@ struct Id.Set.of_list (match_el msg m (Id.Set.elements ks0) (Id.Set.elements ks1)) end - + let meta = S.meta module GetSetRid = MkGetSetM (RegionId) let match_rid = GetSetRid.match_e "match_rid: " S.rid_map @@ -989,10 +992,10 @@ struct let match_aids = GetSetAid.match_es "match_aids: " S.aid_map (** *) - let match_etys (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = + let match_etys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = if ty0 <> ty1 then raise (Distinct "match_etys") else ty0 - let match_rtys (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = + let match_rtys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = let match_distinct_types _ _ = raise (Distinct "match_rtys") in let match_regions r0 r1 = match (r0, r1) with @@ -1004,15 +1007,15 @@ struct in match_types meta match_distinct_types match_regions ty0 ty1 - let match_distinct_literals (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_distinct_adts (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ty : ety) + let match_distinct_adts (_ : eval_ctx) (_ : eval_ctx) (_ty : ety) (_adt0 : adt_value) (_adt1 : adt_value) : typed_value = raise (Distinct "match_distinct_adts") - let match_shared_borrows (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) (match_typed_values : typed_value -> typed_value -> typed_value) (_ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = log#ldebug @@ -1033,22 +1036,22 @@ struct (lazy ("MakeCheckEquivMatcher: match_shared_borrows: looked up values:" ^ "sv0: " - ^ typed_value_to_string meta ctx0 v0 + ^ typed_value_to_string ~meta:(Some meta) ctx0 v0 ^ ", sv1: " - ^ typed_value_to_string meta ctx1 v1)); + ^ typed_value_to_string ~meta:(Some meta) ctx1 v1)); let _ = match_typed_values v0 v1 in () in bid - let match_mut_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ty : ety) + let match_mut_borrows (_ : eval_ctx) (_ : eval_ctx) (_ty : ety) (bid0 : borrow_id) (_bv0 : typed_value) (bid1 : borrow_id) (_bv1 : typed_value) (bv : typed_value) : borrow_id * typed_value = let bid = match_borrow_id bid0 bid1 in (bid, bv) - let match_shared_loans (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (_ : ety) + let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) (sv : typed_value) : loan_id_set * typed_value = let ids = match_loan_ids ids0 ids1 in @@ -1058,7 +1061,7 @@ struct (bid1 : loan_id) : loan_id = match_loan_id bid0 bid1 - let match_symbolic_values (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_symbolic_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -1077,12 +1080,12 @@ struct let sv_id = GetSetSid.match_e "match_symbolic_values: ids: " S.sid_map id0 id1 in - let sv_ty = match_rtys meta ctx0 ctx1 sv0.sv_ty sv1.sv_ty in + let sv_ty = match_rtys ctx0 ctx1 sv0.sv_ty sv1.sv_ty in let sv = { sv_id; sv_ty } in sv else ( (* Check: fixed values are fixed *) - cassert (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)) meta "Fixed values should be fixed"; + sanity_check (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)) meta; (* Update the symbolic value mapping *) let sv1 = mk_typed_value_from_symbolic_value sv1 in @@ -1095,21 +1098,21 @@ struct we want *) sv0) - let match_symbolic_with_other (meta : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( - cassert left meta "TODO: error message"; + sanity_check left meta; let id = sv.sv_id in (* Check: fixed values are fixed *) - cassert (not (SymbolicValueId.InjSubst.mem id !S.sid_map)) meta "Fixed values should be fixed"; + sanity_check (not (SymbolicValueId.InjSubst.mem id !S.sid_map)) meta; (* Update the binding for the target symbolic value *) S.sid_to_value_map := SymbolicValueId.Map.add_strict id v !S.sid_to_value_map; (* Return - the returned value is not used, so we can return whatever we want *) v) - let match_bottom_with_other (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) + let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) (v : typed_value) : typed_value = (* It can happen that some variables get initialized in some branches and not in some others, which causes problems when matching. *) @@ -1126,47 +1129,47 @@ struct ^ Print.bool_to_string left ^ "\n- value to match with bottom:\n" ^ show_typed_value v)) - let match_distinct_aadts _ _ _ _ _ _ _ _ = + let match_distinct_aadts _ _ _ _ _ _ _ = raise (Distinct "match_distinct_adts") - let match_ashared_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _ty1 bid1 ty + let match_ashared_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _ty1 bid1 ty = let bid = match_borrow_id bid0 bid1 in let value = ABorrow (ASharedBorrow bid) in { value; ty } - let match_amut_borrows (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _av0 _ty1 bid1 + let match_amut_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _av0 _ty1 bid1 _av1 ty av = let bid = match_borrow_id bid0 bid1 in let value = ABorrow (AMutBorrow (bid, av)) in { value; ty } - let match_ashared_loans (_ : Meta.meta) (_ : eval_ctx) (_ : eval_ctx) _ty0 ids0 _v0 _av0 _ty1 + let match_ashared_loans (_ : eval_ctx) (_ : eval_ctx) _ty0 ids0 _v0 _av0 _ty1 ids1 _v1 _av1 ty v av = let bids = match_loan_ids ids0 ids1 in let value = ALoan (ASharedLoan (bids, v, av)) in { value; ty } - let match_amut_loans (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 + let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 id1 _av1 ty av = log#ldebug (lazy ("MakeCheckEquivMatcher:match_amut_loans:" ^ "\n- id0: " ^ BorrowId.to_string id0 ^ "\n- id1: " ^ BorrowId.to_string id1 ^ "\n- ty: " ^ ty_to_string ctx0 ty ^ "\n- av: " - ^ typed_avalue_to_string meta ctx1 av)); + ^ typed_avalue_to_string ~meta:(Some meta) ctx1 av)); let id = match_loan_id id0 id1 in let value = ALoan (AMutLoan (id, av)) in { value; ty } - let match_avalues (meta : Meta.meta) (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = + let match_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = log#ldebug (lazy ("avalues don't match:\n- v0: " - ^ typed_avalue_to_string meta ctx0 v0 + ^ typed_avalue_to_string ~meta:(Some meta) ctx0 v0 ^ "\n- v1: " - ^ typed_avalue_to_string meta ctx1 v1)); + ^ typed_avalue_to_string ~meta:(Some meta) ctx1 v1)); raise (Distinct "match_avalues") end @@ -1178,9 +1181,9 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) (lazy ("match_ctxs:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter meta ctx0 + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx0 ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter meta ctx1 + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) ctx1 ^ "\n\n")); (* Initialize the maps and instantiate the matcher *) @@ -1222,6 +1225,7 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) in let module S : MatchCheckEquivState = struct + let meta = meta let check_equiv = check_equiv let rid_map = rid_map let blid_map = blid_map @@ -1288,7 +1292,7 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) log#ldebug (lazy "match_abstractions: matching values"); let _ = List.map - (fun (v0, v1) -> M.match_typed_avalues meta ctx0 ctx1 v0 v1) + (fun (v0, v1) -> M.match_typed_avalues ctx0 ctx1 v0 v1) (List.combine avalues0 avalues1) in log#ldebug (lazy "match_abstractions: values matched OK"); @@ -1309,9 +1313,9 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) ^ "\n- aid_map: " ^ AbstractionId.InjSubst.show_t !aid_map ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter meta { ctx0 with env = List.rev env0 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter meta { ctx1 with env = List.rev env1 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx1 with env = List.rev env1 } ^ "\n\n")); match (env0, env1) with @@ -1320,19 +1324,19 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) be the same and their values equal (and the borrows/loans/symbolic *) if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Fixed values: the values must be equal *) - cassert (b0 = b1) meta "The fixed values should be equal"; - cassert (v0 = v1) meta "The fixed values should be equal"; + sanity_check (b0 = b1) meta; + sanity_check (v0 = v1) meta; (* The ids present in the left value must be fixed *) let ids, _ = compute_typed_value_ids v0 in - cassert ((not S.check_equiv) || ids_are_fixed ids)) meta "TODO: error message"; + sanity_check ((not S.check_equiv) || ids_are_fixed ids)) meta; (* We still match the values - allows to compute mappings (which are the identity actually) *) - let _ = M.match_typed_values meta ctx0 ctx1 v0 v1 in + let _ = M.match_typed_values ctx0 ctx1 v0 v1 in match_envs env0' env1' | EBinding (BVar b0, v0) :: env0', EBinding (BVar b1, v1) :: env1' -> - cassert (b0 = b1) meta "TODO: error message"; + sanity_check (b0 = b1) meta; (* Match the values *) - let _ = M.match_typed_values meta ctx0 ctx1 v0 v1 in + let _ = M.match_typed_values ctx0 ctx1 v0 v1 in (* Continue *) match_envs env0' env1' | EAbs abs0 :: env0', EAbs abs1 :: env1' -> @@ -1341,10 +1345,10 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( log#ldebug (lazy "match_ctxs: match_envs: matching abs: fixed abs"); (* Still in the prefix: the abstractions must be the same *) - cassert (abs0 = abs1) meta "The abstractions should be the same"; + sanity_check (abs0 = abs1) meta; (* Their ids must be fixed *) let ids, _ = compute_abs_ids abs0 in - cassert ((not S.check_equiv) || ids_are_fixed ids) meta "The ids should be fixed"; + sanity_check ((not S.check_equiv) || ids_are_fixed ids) meta; (* Continue *) match_envs env0' env1') else ( @@ -1408,7 +1412,7 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (lazy ("prepare_match_ctx_with_target:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- src_ctx: " - ^ eval_ctx_to_string meta src_ctx ^ "\n- tgt_ctx: " ^ eval_ctx_to_string meta tgt_ctx + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n- tgt_ctx: " ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx )); (* End the loans which lead to mismatches when joining *) let rec cf_reorganize_join_tgt : cm_fun = @@ -1437,6 +1441,7 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id let nabs = ref [] in let module S : MatchJoinState = struct + let meta = meta let loop_id = loop_id let nabs = nabs end in @@ -1448,12 +1453,12 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (fun (var0, var1) -> match (var0, var1) with | EBinding (BDummy b0, v0), EBinding (BDummy b1, v1) -> - cassert (b0 = b1) meta "TODO: error message"; - let _ = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in + sanity_check (b0 = b1) meta; + let _ = M.match_typed_values src_ctx tgt_ctx v0 v1 in () | EBinding (BVar b0, v0), EBinding (BVar b1, v1) -> - cassert (b0 = b1) meta "TODO: error message"; - let _ = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in + sanity_check (b0 = b1) meta; + let _ = M.match_typed_values src_ctx tgt_ctx v0 v1 in () | _ -> craise meta "Unexpected") (List.combine filt_src_env filt_tgt_env) @@ -1475,6 +1480,7 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id environment *) let nvalues = ref [] in let module S : MatchMoveState = struct + let meta = meta let loop_id = loop_id let nvalues = nvalues end in @@ -1485,12 +1491,12 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (fun (var0, var1) -> match (var0, var1) with | EBinding (BDummy b0, v0), EBinding ((BDummy b1 as var1), v1) -> - cassert (b0 = b1) meta "TODO: error message"; - let v = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in + sanity_check (b0 = b1) meta; + let v = M.match_typed_values src_ctx tgt_ctx v0 v1 in (var1, v) | EBinding (BVar b0, v0), EBinding ((BVar b1 as var1), v1) -> - cassert (b0 = b1) meta "TODO: error message"; - let v = M.match_typed_values meta src_ctx tgt_ctx v0 v1 in + sanity_check (b0 = b1) meta; + let v = M.match_typed_values src_ctx tgt_ctx v0 v1 in (var1, v) | _ -> craise meta "Unexpected") (List.combine filt_src_env filt_tgt_env) @@ -1520,8 +1526,8 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (lazy ("cf_reorganize_join_tgt: done with borrows/loans and moves:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- src_ctx: " - ^ eval_ctx_to_string meta src_ctx ^ "\n- tgt_ctx: " - ^ eval_ctx_to_string meta tgt_ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n- tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); cf tgt_ctx with ValueMatchFailure e -> @@ -1590,7 +1596,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) let filt_src_env, new_absl, new_dummyl = ctx_split_fixed_new meta fixed_ids src_ctx in - cassert (new_dummyl = []) meta "TODO: error message"; + sanity_check (new_dummyl = []) meta; let filt_tgt_ctx = { tgt_ctx with env = filt_tgt_env } in let filt_src_ctx = { src_ctx with env = filt_src_env } in @@ -1622,13 +1628,13 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs:" ^ "\n\n- src_ctx: " - ^ eval_ctx_to_string meta src_ctx ^ "\n\n- tgt_ctx: " - ^ eval_ctx_to_string meta tgt_ctx ^ "\n\n- filt_tgt_ctx: " - ^ eval_ctx_to_string_no_filter meta filt_tgt_ctx + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n\n- tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx ^ "\n\n- filt_tgt_ctx: " + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) filt_tgt_ctx ^ "\n\n- filt_src_ctx: " - ^ eval_ctx_to_string_no_filter meta filt_src_ctx + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) filt_src_ctx ^ "\n\n- new_absl:\n" - ^ eval_ctx_to_string meta + ^ eval_ctx_to_string ~meta:(Some meta) { src_ctx with env = List.map (fun abs -> EAbs abs) new_absl } ^ "\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- fp_bl_maps:\n" ^ show_borrow_loan_corresp fp_bl_maps @@ -1726,7 +1732,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) abstractions and in the *variable bindings* once we allow symbolic values containing borrows to not be eagerly expanded. *) - cassert Config.greedy_expand_symbolics_with_borrows meta "TODO: error message"; + sanity_check Config.greedy_expand_symbolics_with_borrows meta; (* Update the borrows and loans in the abstractions of the target context. @@ -1795,8 +1801,8 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) (* No mapping: this means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) and because of this, it should actually be mapped to itself *) - cassert ( - BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id) meta "The borrow should mapped to itself: no mapping means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) "; + sanity_check ( + BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id) meta; id | Some id -> id @@ -1808,8 +1814,8 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) method! visit_abs env abs = match abs.kind with | Loop (loop_id', rg_id, kind) -> - cassert (loop_id' = loop_id) meta "TODO: error message"; - cassert (kind = LoopSynthInput) meta "TODO: error message"; + sanity_check (loop_id' = loop_id) meta; + sanity_check (kind = LoopSynthInput) meta; let can_end = false in let kind : abs_kind = Loop (loop_id, rg_id, LoopCall) in let abs = { abs with kind; can_end } in @@ -1827,7 +1833,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: done:\n\ - - result ctx:\n" ^ eval_ctx_to_string meta tgt_ctx)); + - result ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); (* Sanity check *) if !Config.sanity_checks then diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 3733c06d..93ce0515 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -100,8 +100,8 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : (* Check consistency *) (match (proj_kind, type_id) with | ProjAdt (def_id, opt_variant_id), TAdtId def_id' -> - cassert (def_id = def_id') meta "TODO: Error message"; - cassert (opt_variant_id = adt.variant_id) meta "TODO: Error message" + sanity_check (def_id = def_id') meta; + sanity_check (opt_variant_id = adt.variant_id) meta | _ -> craise meta "Unreachable"); (* Actually project *) let fv = FieldId.nth adt.field_values field_id in @@ -117,7 +117,7 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : Ok (ctx, { res with updated })) (* Tuples *) | Field (ProjTuple arity, field_id), VAdt adt, TAdt (TTuple, _) -> ( - cassert (arity = List.length adt.field_values) meta "TODO: Error message"; + sanity_check (arity = List.length adt.field_values) meta; let fv = FieldId.nth adt.field_values field_id in (* Project *) match access_projection meta access ctx update p' fv with @@ -349,16 +349,16 @@ let write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : type let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) (generics : generic_args) : typed_value = - cassert (TypesUtils.generic_args_only_erased_regions generics) meta "TODO: Error message"; + sanity_check (TypesUtils.generic_args_only_erased_regions generics) meta; (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) let def = ctx_lookup_type_decl ctx def_id in - cassert (List.length generics.regions = List.length def.generics.regions) meta "TODO: Error message"; + sanity_check (List.length generics.regions = List.length def.generics.regions) meta; (* Compute the field types *) let field_types = - AssociatedTypes.type_decl_get_inst_norm_field_etypes ctx def opt_variant_id + AssociatedTypes.type_decl_get_inst_norm_field_etypes meta ctx def opt_variant_id generics in (* Initialize the expanded value *) @@ -425,14 +425,14 @@ let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), TAdt (TAdtId def_id', generics) ) -> - cassert (def_id = def_id') meta "TODO: Error message"; + sanity_check (def_id = def_id') meta; compute_expanded_bottom_adt_value meta ctx def_id opt_variant_id generics (* Tuples *) | ( Field (ProjTuple arity, _), TAdt (TTuple, { regions = []; types; const_generics = []; trait_refs = [] }) ) -> - cassert (arity = List.length types) meta "TODO: Error message"; + sanity_check (arity = List.length types) meta; (* Generate the field values *) compute_expanded_bottom_tuple_value meta types | _ -> @@ -616,7 +616,7 @@ let prepare_lplace (config : config) (meta : Meta.meta) (p : place) (cf : typed_ log#ldebug (lazy ("prepare_lplace:" ^ "\n- p: " ^ place_to_string ctx p - ^ "\n- Initial context:\n" ^ eval_ctx_to_string meta ctx)); + ^ "\n- Initial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Access the place *) let access = Write in let cc = update_ctx_along_write_place config meta access p in diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 5f83b938..809303ae 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -84,7 +84,7 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VLoan _, _ -> craise meta "Unreachable" | VSymbolic s, _ -> (* Check that the projection doesn't contain ended regions *) - cassert (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) meta "TODO: error message"; + sanity_check (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) meta; [ AsbProjReborrows (s, ty) ] | _ -> craise meta "Unreachable" @@ -212,13 +212,13 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " ^ RegionId.Set.to_string None rset2 ^ "\n")); - cassert (not (projections_intersect meta ty1 rset1 ty2 rset2))) meta "TODO: error message"; + sanity_check (not (projections_intersect meta ty1 rset1 ty2 rset2))) meta; ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror (lazy ("apply_proj_borrows: unexpected inputs:\n- input value: " - ^ typed_value_to_string meta ctx v + ^ typed_value_to_string ~meta:(Some meta) ctx v ^ "\n- proj rty: " ^ ty_to_string ctx ty)); craise meta "Unreachable" in @@ -464,7 +464,7 @@ let apply_reborrows (meta : Meta.meta) (reborrows : (BorrowId.id * BorrowId.id) (* Visit *) let ctx = obj#visit_eval_ctx () ctx in (* Check that there are no reborrows remaining *) - cassert (!reborrows = []) meta "TODO: error message"; + sanity_check (!reborrows = []) meta; (* Return *) ctx @@ -483,7 +483,7 @@ let prepare_reborrows (config : config) (meta : Meta.meta) (allow_reborrows : bo let apply_registered_reborrows (ctx : eval_ctx) : eval_ctx = match config.mode with | ConcreteMode -> - cassert (!reborrows = []) meta "TODO: error message"; + sanity_check (!reborrows = []) meta; ctx | SymbolicMode -> (* Apply the reborrows *) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 5e8f7c55..a872f24a 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -24,7 +24,7 @@ let drop_value (config : config) (meta : Meta.meta) (p : place) : cm_fun = log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Note that we use [Write], not [Move]: we allow to drop values *below* borrows *) let access = Write in (* First make sure we can access the place, by ending loans or expanding @@ -45,7 +45,7 @@ let drop_value (config : config) (meta : Meta.meta) (p : place) : cm_fun = log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); cf ctx in (* Compose and apply *) @@ -99,9 +99,9 @@ let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : log#ldebug (lazy ("assign_to_place:" ^ "\n- rv: " - ^ typed_value_to_string meta ctx rv + ^ typed_value_to_string ~meta:(Some meta) ctx rv ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Push the rvalue to a dummy variable, for bookkeeping *) let rvalue_vid = fresh_dummy_var_id () in let cc = push_dummy_var rvalue_vid rv in @@ -119,16 +119,16 @@ let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : let ctx = ctx_push_dummy_var ctx dest_vid mv in (* Write to the destination *) (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) - cassert (not (bottom_in_value ctx.ended_regions rv)) meta "TODO: Error message"; + exec_assert (not (bottom_in_value ctx.ended_regions rv)) meta "The value to move contains bottom"; (* Update the destination *) let ctx = write_place meta Write p rv ctx in (* Debug *) log#ldebug (lazy ("assign_to_place:" ^ "\n- rv: " - ^ typed_value_to_string meta ctx rv + ^ typed_value_to_string ~meta:(Some meta) ctx rv ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string meta ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Continue *) cf ctx in @@ -149,7 +149,7 @@ let eval_assertion_concrete (config : config) (meta : Meta.meta) (assertion : as if b = assertion.expected then cf Unit ctx else cf Panic ctx | _ -> craise - meta ("Expected a boolean, got: " ^ typed_value_to_string meta ctx v) + meta ("Expected a boolean, got: " ^ typed_value_to_string ~meta:(Some meta) ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -167,7 +167,7 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) (* Evaluate the assertion *) let eval_assert cf (v : typed_value) : m_fun = fun ctx -> - cassert (v.ty = TLiteral TBool) meta "TODO: Error message"; + sanity_check (v.ty = TLiteral TBool) meta; (* We make a choice here: we could completely decouple the concrete and * symbolic executions here but choose not to. In the case where we * know the concrete value of the boolean we test, we use this value @@ -178,8 +178,8 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) (* Delegate to the concrete evaluation function *) eval_assertion_concrete config meta assertion cf ctx | VSymbolic sv -> - cassert (config.mode = SymbolicMode) meta "TODO: Error message"; - cassert (sv.sv_ty = TLiteral TBool) meta "TODO: Error message"; + sanity_check(config.mode = SymbolicMode) meta; + sanity_check (sv.sv_ty = TLiteral TBool) meta; (* We continue the execution as if the test had succeeded, and thus * perform the symbolic expansion: sv ~~> true. * We will of course synthesize an assertion in the generated code @@ -194,7 +194,7 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) S.synthesize_assertion ctx v expr | _ -> craise - meta ("Expected a boolean, got: " ^ typed_value_to_string meta ctx v) + meta ("Expected a boolean, got: " ^ typed_value_to_string ~meta:(Some meta) ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -218,7 +218,7 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_i ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p ^ "\n- variant id: " ^ VariantId.to_string variant_id - ^ "\n- initial context:\n" ^ eval_ctx_to_string meta ctx)); + ^ "\n- initial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Access the value *) let access = Write in let cc = update_ctx_along_read_place config meta access p in @@ -259,7 +259,7 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_i in assign_to_place config meta bottom_v p (cf Unit) ctx | _, VSymbolic _ -> - cassert (config.mode = SymbolicMode) meta "The Config mode should be SymbolicMode"; + sanity_check (config.mode = SymbolicMode) meta; (* This is a bit annoying: in theory we should expand the symbolic value * then set the discriminant, because in the case the discriminant is * exactly the one we set, the fields are left untouched, and in the @@ -287,13 +287,13 @@ let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) *) let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : assumed_fun_id) (generics : generic_args) : ety = - cassert (generics.trait_refs = []) meta "TODO: Error message"; + sanity_check (generics.trait_refs = []) meta; (* [Box::free] has a special treatment *) match fid with | BoxFree -> - cassert (generics.regions = []) meta "TODO: Error message"; - cassert (List.length generics.types = 1) meta "TODO: Error message"; - cassert (generics.const_generics = []) meta "TODO: Error message"; + sanity_check (generics.regions = []) meta; + sanity_check (List.length generics.types = 1) meta; + sanity_check (generics.const_generics = []) meta; mk_unit_ty | _ -> (* Retrieve the function's signature *) @@ -324,7 +324,7 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) (cf : typed_value option -> m_fun) : m_fun = fun ctx -> (* Debug *) - log#ldebug (lazy ("pop_frame:\n" ^ eval_ctx_to_string meta ctx)); + log#ldebug (lazy ("pop_frame:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* List the local variables, but the return variable *) let ret_vid = VarId.zero in @@ -377,7 +377,7 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) log#ldebug (lazy ("pop_frame: after dropping outer loans in local variables:\n" - ^ eval_ctx_to_string meta ctx))) + ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* Pop the frame - we remove the [Frame] delimiter, and reintroduce all @@ -479,7 +479,7 @@ let eval_box_free (config : config) (meta : Meta.meta) (generics : generic_args) (* Required type checking *) let input_box = InterpreterPaths.read_place meta Write input_box_place ctx in (let input_ty = ty_get_box input_box.ty in - cassert (input_ty = boxed_ty)) meta "TODO: Error message"; + sanity_check (input_ty = boxed_ty)) meta; (* Drop the value *) let cc = drop_value config meta input_box_place in @@ -930,7 +930,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = (lazy ("\n**About to evaluate statement**: [\n" ^ statement_to_string_with_tab ctx st - ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string st.meta ctx ^ "\n\n")); + ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string ~meta:(Some st.meta) ctx ^ "\n\n")); (* Take a snapshot of the current context for the purpose of generating pretty names *) let cc = S.cf_save_snapshot in @@ -963,7 +963,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = log#ldebug (lazy ("about to assign to place: " ^ place_to_string ctx p - ^ "\n- Context:\n" ^ eval_ctx_to_string st.meta ctx)); + ^ "\n- Context:\n" ^ eval_ctx_to_string ~meta:(Some st.meta) ctx)); match res with | Error EPanic -> cf Panic ctx | Ok rv -> ( @@ -1037,7 +1037,7 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) - cassert (ty_no_regions global.ty) meta "TODO: Error message"; + cassert (ty_no_regions global.ty) global.meta "Const globals should not contain regions"; (* Instantiate the type *) (* There shouldn't be any reference to Self *) let tr_self : trait_instance_id = UnknownTrait __FUNCTION__ in @@ -1049,7 +1049,7 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self global.ty in - let sval = mk_fresh_symbolic_value ty in + let sval = mk_fresh_symbolic_value global.meta ty in let cc = assign_to_place config global.meta (mk_typed_value_from_symbolic_value sval) dest in @@ -1250,7 +1250,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) - cassert (generics.trait_refs = []) body.meta "Traits are not supported yet TODO: error message"; + cassert (generics.trait_refs = []) body.meta "Traits are not supported yet in concrete mode"; (* There shouldn't be any reference to Self *) let tr_self = UnknownTrait __FUNCTION__ in let subst = @@ -1259,7 +1259,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - cassert (List.length args = body.arg_count) body.meta "TODO: Error message"; + sanity_check(List.length args = body.arg_count) body.meta; let cc = eval_operands config body.meta args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result @@ -1295,7 +1295,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let cc = comp cc (push_uninitialized_vars meta locals) in (* Execute the function body *) - let cc = comp cc (eval_function_body config meta body_st) in + let cc = comp cc (eval_function_body config body_st) in (* Pop the stack frame and move the return value to its destination *) let cf_finish cf res = @@ -1387,11 +1387,11 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.met * be fed to functions (i.e., symbolic values output from function return * values and which contain borrows of borrows can't be used as function * inputs *) - cassert ( + sanity_check ( List.for_all (fun arg -> not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) - args) meta "The input argument should not contain symbolic values that can't be fed to functions TODO: error message"; + args) meta; (* Initialize the abstractions and push them in the context. * First, we define the function which, given an initialized, empty @@ -1538,7 +1538,7 @@ and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) (fi regions_hierarchy inst_sig generics None args dest cf ctx (** Evaluate a statement seen as a function body *) -and eval_function_body (config : config) (meta : Meta.meta) (body : statement) : st_cm_fun = +and eval_function_body (config : config) (body : statement) : st_cm_fun = fun cf ctx -> log#ldebug (lazy "eval_function_body:"); let cc = eval_statement config body in @@ -1550,7 +1550,7 @@ and eval_function_body (config : config) (meta : Meta.meta) (body : statement) : * checking the invariants *) let cc = greedy_expand_symbolic_values config body.meta in (* Sanity check *) - let cc = comp_check_ctx cc (Invariants.check_invariants meta) in (* Check if right meta *) + let cc = comp_check_ctx cc (Invariants.check_invariants body.meta) in (* Check if right meta *) (* Continue *) cc (cf res) in diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index 519d2c8e..13743cb1 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -48,4 +48,4 @@ val create_push_abstractions_from_abs_region_groups : val eval_statement : config -> statement -> st_cm_fun (** Evaluate a statement seen as a function body *) -val eval_function_body : config -> Meta.meta -> statement -> st_cm_fun +val eval_function_body : config -> statement -> st_cm_fun diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index be8400f7..a24cd543 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -20,7 +20,7 @@ let log = Logging.interpreter_log let get_cf_ctx_no_synth (meta : Meta.meta) (f : cm_fun) (ctx : eval_ctx) : eval_ctx = let nctx = ref None in let cf ctx = - cassert (!nctx = None) meta "TODO: error message"; + sanity_check (!nctx = None) meta; nctx := Some ctx; None in @@ -62,9 +62,9 @@ let statement_to_string ctx = Print.EvalCtx.statement_to_string ctx "" " " let statement_to_string_with_tab ctx = Print.EvalCtx.statement_to_string ctx " " " " -let env_elem_to_string meta ctx = Print.EvalCtx.env_elem_to_string meta ctx "" " " -let env_to_string meta ctx env = eval_ctx_to_string meta { ctx with env } -let abs_to_string meta ctx = Print.EvalCtx.abs_to_string meta ctx "" " " +let env_elem_to_string meta ctx = Print.EvalCtx.env_elem_to_string ~meta:(Some meta) ctx "" " " +let env_to_string meta ctx env = eval_ctx_to_string ~meta:(Some meta) { ctx with env } +let abs_to_string meta ctx = Print.EvalCtx.abs_to_string ~meta:(Some meta) ctx "" " " let same_symbolic_id (sv0 : symbolic_value) (sv1 : symbolic_value) : bool = sv0.sv_id = sv1.sv_id @@ -85,12 +85,12 @@ let mk_fresh_symbolic_value (meta : Meta.meta) (ty : ty) : symbolic_value = svalue let mk_fresh_symbolic_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : symbolic_value = - cassert (ty_no_regions ty) meta "TODO: error message"; + sanity_check (ty_no_regions ty) meta; mk_fresh_symbolic_value meta ty (** Create a fresh symbolic value *) let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = - cassert (ty_is_rty rty) meta "TODO: error message"; + sanity_check (ty_is_rty rty) meta; let ty = Substitute.erase_regions rty in (* Generate the fresh a symbolic value *) let value = mk_fresh_symbolic_value meta rty in @@ -98,7 +98,7 @@ let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = { value; ty } let mk_fresh_symbolic_typed_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : typed_value = - cassert (ty_no_regions ty) meta "TODO: error message"; + sanity_check (ty_no_regions ty) meta; mk_fresh_symbolic_typed_value meta ty (** Create a typed value from a symbolic value. *) @@ -127,7 +127,7 @@ let mk_aproj_loans_value_from_symbolic_value (regions : RegionId.Set.t) (** Create a borrows projector from a symbolic value *) let mk_aproj_borrows_from_symbolic_value (meta : Meta.meta) (proj_regions : RegionId.Set.t) (svalue : symbolic_value) (proj_ty : ty) : aproj = - cassert (ty_is_rty proj_ty) meta "TODO: error message"; + sanity_check (ty_is_rty proj_ty) meta; if ty_has_regions_in_set proj_regions proj_ty then AProjBorrows (svalue, proj_ty) else AIgnoredProjBorrows @@ -153,7 +153,7 @@ let remove_borrow_from_asb (meta : Meta.meta) (bid : BorrowId.id) (asb : abstrac false)) asb in - cassert (!removed = 1) meta "TODO: error message"; + sanity_check (!removed = 1) meta; asb (** We sometimes need to return a value whose type may vary depending on @@ -499,8 +499,8 @@ let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (generics : generic_ (* Generate the type substitution Note that for now we don't support instantiating the type parameters with types containing regions. *) - cassert (List.for_all TypesUtils.ty_no_regions generics.types) meta "TODO: error message"; - cassert (TypesUtils.trait_instance_id_no_regions tr_self) meta "TODO: error message"; + sanity_check (List.for_all TypesUtils.ty_no_regions generics.types) meta; + sanity_check (TypesUtils.trait_instance_id_no_regions tr_self) meta; let tsubst = Substitute.make_type_subst_from_vars sg.generics.types generics.types in diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 50f008b8..9b389ba5 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -55,7 +55,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : (* Link all the id representants to a borrow information *) let borrows_infos : borrow_info BorrowId.Map.t ref = ref BorrowId.Map.empty in let context_to_string () : string = - eval_ctx_to_string meta ctx ^ "- representants:\n" + eval_ctx_to_string ~meta:(Some meta) ctx ^ "- representants:\n" ^ ids_reprs_to_string " " !ids_reprs ^ "\n- info:\n" ^ borrows_infos_to_string " " !borrows_infos @@ -77,12 +77,12 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let infos = !borrows_infos in (* Use the first borrow id as representant *) let repr_bid = BorrowId.Set.min_elt bids in - cassert (not (BorrowId.Map.mem repr_bid infos)) meta "TODO: Error message"; + sanity_check (not (BorrowId.Map.mem repr_bid infos)) meta; (* Insert the mappings to the representant *) let reprs = BorrowId.Set.fold (fun bid reprs -> - cassert (not (BorrowId.Map.mem bid reprs)) meta "TODO: Error message"; + sanity_check (not (BorrowId.Map.mem bid reprs)) meta; BorrowId.Map.add bid repr_bid reprs) bids reprs in @@ -212,10 +212,10 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : | RShared, (BShared | BReserved) | RMut, BMut -> () | _ -> craise meta "Invariant not satisfied"); (* A reserved borrow can't point to a value inside an abstraction *) - cassert (kind <> BReserved || not info.loan_in_abs) meta "A reserved borrow can't point to a value inside an abstraction"; + sanity_check (kind <> BReserved || not info.loan_in_abs) meta; (* Insert the borrow id *) let borrow_ids = info.borrow_ids in - cassert (not (BorrowId.Set.mem bid borrow_ids)) meta "TODO: Error message"; + sanity_check (not (BorrowId.Set.mem bid borrow_ids)) meta; let info = { info with borrow_ids = BorrowId.Set.add bid borrow_ids } in (* Update the info in the map *) update_info bid info @@ -270,7 +270,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : List.iter (fun (rkind, bid) -> let info = find_info bid in - cassert (info.loan_kind = rkind) meta "Not all the ignored loans are present at the proper place") + sanity_check (info.loan_kind = rkind) meta) !ignored_loans; (* Then, check the borrow infos *) @@ -278,11 +278,11 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : (fun _ info -> (* Note that we can't directly compare the sets - I guess they are * different depending on the order in which we add the elements... *) - cassert ( + sanity_check ( BorrowId.Set.elements info.loan_ids - = BorrowId.Set.elements info.borrow_ids) meta "TODO: Error message"; + = BorrowId.Set.elements info.borrow_ids) meta; match info.loan_kind with - | RMut -> cassert (BorrowId.Set.cardinal info.loan_ids = 1) meta "TODO: Error message" + | RMut -> sanity_check (BorrowId.Set.cardinal info.loan_ids = 1) meta | RShared -> ()) !borrows_infos @@ -297,7 +297,7 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = method! visit_VBottom info = (* No ⊥ inside borrowed values *) - cassert (Config.allow_bottom_below_borrow || not info.outer_borrow) meta "There should be no ⊥ inside borrowed values" + sanity_check (Config.allow_bottom_below_borrow || not info.outer_borrow) meta method! visit_ABottom _info = (* ⊥ inside an abstraction is not the same as in a regular value *) @@ -310,7 +310,7 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | VSharedLoan (_, _) -> set_outer_shared info | VMutLoan _ -> (* No mutable loan inside a shared loan *) - cassert (not info.outer_shared) meta "There should be no mutable loan inside a shared loan"; + sanity_check (not info.outer_shared) meta; set_outer_mut info in (* Continue exploring *) @@ -322,7 +322,7 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = match bc with | VSharedBorrow _ -> set_outer_shared info | VReservedMutBorrow _ -> - cassert (not info.outer_borrow) meta "TODO: Error message"; + sanity_check (not info.outer_borrow) meta; set_outer_shared info | VMutBorrow (_, _) -> set_outer_mut info in @@ -369,7 +369,7 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : unit = match (cv, ty) with - | VScalar sv, TInteger int_ty -> cassert (sv.int_ty = int_ty) meta "TODO: Error message" + | VScalar sv, TInteger int_ty -> sanity_check (sv.int_ty = int_ty) meta | VBool _, TBool | VChar _, TChar -> () | _ -> craise meta "Erroneous typing" @@ -393,17 +393,17 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = method! visit_EBinding info binder v = (* We also check that the regions are erased *) - cassert (ty_is_ety v.ty) meta "The regions should be erased"; + sanity_check (ty_is_ety v.ty) meta; super#visit_EBinding info binder v method! visit_symbolic_value inside_abs v = (* Check that the types have regions *) - cassert (ty_is_rty v.sv_ty) meta "The types should have regions"; + sanity_check (ty_is_rty v.sv_ty) meta; super#visit_symbolic_value inside_abs v method! visit_typed_value info tv = (* Check that the types have erased regions *) - cassert (ty_is_ety tv.ty) meta "The types should have erased regions"; + sanity_check (ty_is_ety tv.ty) meta; (* Check the current pair (value, type) *) (match (tv.value, tv.ty) with | VLiteral cv, TLiteral ty -> check_literal_type meta cv ty @@ -413,40 +413,40 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - cassert ( - List.length generics.regions = List.length def.generics.regions) meta "TODO: Error message"; - cassert (List.length generics.types = List.length def.generics.types) meta "TODO: Error message"; + sanity_check ( + List.length generics.regions = List.length def.generics.regions) meta; + sanity_check (List.length generics.types = List.length def.generics.types) meta; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - cassert (VariantId.to_int variant_id < List.length variants) meta "The variant id should be consistent" + sanity_check (VariantId.to_int variant_id < List.length variants) meta | None, Struct _ -> () | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) let field_types = - AssociatedTypes.type_decl_get_inst_norm_field_etypes ctx def + AssociatedTypes.type_decl_get_inst_norm_field_etypes meta ctx def av.variant_id generics in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : typed_value * ty) -> cassert (v.ty = ty) meta "The field types are not correct") + (fun ((v, ty) : typed_value * ty) -> sanity_check (v.ty = ty) meta) fields_with_types (* Tuple case *) | VAdt av, TAdt (TTuple, generics) -> - cassert (generics.regions = []) meta "TODO: Error message"; - cassert (generics.const_generics = []) meta "TODO: Error message"; - cassert (av.variant_id = None) meta "TODO: Error message"; + sanity_check (generics.regions = []) meta; + sanity_check (generics.const_generics = []) meta; + sanity_check (av.variant_id = None) meta; (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) let fields_with_types = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : typed_value * ty) -> cassert (v.ty = ty) meta "The fields does not have the proper values or there are not as many fields as field types at the same time TODO: error message") + (fun ((v, ty) : typed_value * ty) -> sanity_check (v.ty = ty) meta) fields_with_types (* Assumed type case *) | VAdt av, TAdt (TAssumed aty_id, generics) -> ( - cassert (av.variant_id = None) meta "TODO: Error message"; + sanity_check (av.variant_id = None) meta; match ( aty_id, av.field_values, @@ -456,20 +456,20 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = with (* Box *) | TBox, [ inner_value ], [], [ inner_ty ], [] -> - cassert (inner_value.ty = inner_ty) meta "TODO: Error message" + sanity_check (inner_value.ty = inner_ty) meta | TArray, inner_values, _, [ inner_ty ], [ cg ] -> (* *) - cassert ( + sanity_check ( List.for_all (fun (v : typed_value) -> v.ty = inner_ty) - inner_values) meta "TODO: Error message"; + inner_values) meta; (* The length is necessarily concrete *) let len = (ValuesUtils.literal_as_scalar (TypesUtils.const_generic_as_literal cg)) .value in - cassert (Z.of_int (List.length inner_values) = len) meta "TODO: Error message" + sanity_check (Z.of_int (List.length inner_values) = len) meta | (TSlice | TStr), _, _, _, _ -> craise meta "Unexpected" | _ -> craise meta "Erroneous type") | VBottom, _ -> (* Nothing to check *) () @@ -481,27 +481,27 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - cassert (sv.ty = ref_ty) meta "TODO: Error message" + sanity_check (sv.ty = ref_ty) meta | _ -> craise meta "Inconsistent context") | VMutBorrow (_, bv), RMut -> - cassert ( + sanity_check ( (* Check that the borrowed value has the proper type *) - bv.ty = ref_ty) meta "TODO: Error message" + bv.ty = ref_ty) meta | _ -> craise meta "Erroneous typing") | VLoan lc, ty -> ( match lc with - | VSharedLoan (_, sv) -> cassert (sv.ty = ty) meta "TODO: Error message" + | VSharedLoan (_, sv) -> sanity_check (sv.ty = ty) meta | VMutLoan bid -> ( (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in match glc with - | Concrete (VMutBorrow (_, bv)) -> cassert (bv.ty = ty) meta "The borrowed value does not have the proper type" + | Concrete (VMutBorrow (_, bv)) -> sanity_check (bv.ty = ty) meta | Abstract (AMutBorrow (_, sv)) -> - cassert (Substitute.erase_regions sv.ty = ty) meta "The borrowed value does not have the proper type" + sanity_check (Substitute.erase_regions sv.ty = ty) meta | _ -> craise meta "Inconsistent context")) | VSymbolic sv, ty -> let ty' = Substitute.erase_regions sv.sv_ty in - cassert (ty' = ty) meta "TODO: Error message" + sanity_check (ty' = ty) meta | _ -> craise meta "Erroneous typing"); (* Continue exploring to inspect the subterms *) super#visit_typed_value info tv @@ -516,7 +516,7 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * *) method! visit_typed_avalue info atv = (* Check that the types have regions *) - cassert (ty_is_rty atv.ty) meta "The types should have regions"; + sanity_check (ty_is_rty atv.ty) meta; (* Check the current pair (value, type) *) (match (atv.value, atv.ty) with (* ADT case *) @@ -525,43 +525,43 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - cassert ( - List.length generics.regions = List.length def.generics.regions) meta "TODO: Error message"; - cassert (List.length generics.types = List.length def.generics.types) meta "TODO: Error message"; - cassert ( + sanity_check ( + List.length generics.regions = List.length def.generics.regions) meta; + sanity_check (List.length generics.types = List.length def.generics.types) meta; + sanity_check ( List.length generics.const_generics - = List.length def.generics.const_generics) meta "TODO: Error message"; + = List.length def.generics.const_generics) meta; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - cassert (VariantId.to_int variant_id < List.length variants) meta "The variant id should be consistent" + sanity_check (VariantId.to_int variant_id < List.length variants) meta | None, Struct _ -> () | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) let field_types = - AssociatedTypes.type_decl_get_inst_norm_field_rtypes ctx def + AssociatedTypes.type_decl_get_inst_norm_field_rtypes meta ctx def av.variant_id generics in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : typed_avalue * ty) -> cassert (v.ty = ty) meta "TODO: Error message") + (fun ((v, ty) : typed_avalue * ty) -> sanity_check (v.ty = ty) meta) fields_with_types (* Tuple case *) | AAdt av, TAdt (TTuple, generics) -> - cassert (generics.regions = []) meta "TODO: Error message"; - cassert (generics.const_generics = []) meta "TODO: Error message"; - cassert (av.variant_id = None) meta "TODO: Error message"; + sanity_check (generics.regions = []) meta; + sanity_check (generics.const_generics = []) meta; + sanity_check (av.variant_id = None) meta; (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) let fields_with_types = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : typed_avalue * ty) -> cassert (v.ty = ty) meta "The fields do not have the proper values or there are not as many fields as field types at the same time TODO: Error message") + (fun ((v, ty) : typed_avalue * ty) -> sanity_check (v.ty = ty) meta) fields_with_types (* Assumed type case *) | AAdt av, TAdt (TAssumed aty_id, generics) -> ( - cassert (av.variant_id = None) meta "TODO: Error message"; + sanity_check (av.variant_id = None) meta; match ( aty_id, av.field_values, @@ -571,27 +571,27 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = with (* Box *) | TBox, [ boxed_value ], [], [ boxed_ty ], [] -> - cassert (boxed_value.ty = boxed_ty) meta "TODO: Error message" + sanity_check (boxed_value.ty = boxed_ty) meta | _ -> craise meta "Erroneous type") | ABottom, _ -> (* Nothing to check *) () | ABorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with | AMutBorrow (_, av), RMut -> (* Check that the child value has the proper type *) - cassert (av.ty = ref_ty) meta "TODO: Error message" + sanity_check (av.ty = ref_ty) meta | ASharedBorrow bid, RShared -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan meta ek_all bid ctx in match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - cassert (sv.ty = Substitute.erase_regions ref_ty) meta "TODO: Error message" + sanity_check (sv.ty = Substitute.erase_regions ref_ty) meta | _ -> craise meta "Inconsistent context") - | AIgnoredMutBorrow (_opt_bid, av), RMut -> cassert (av.ty = ref_ty) meta "TODO: Error message" + | AIgnoredMutBorrow (_opt_bid, av), RMut -> sanity_check (av.ty = ref_ty) meta | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, RMut ) -> - cassert (given_back.ty = ref_ty) meta "TODO: Error message"; - cassert (child.ty = ref_ty) meta "TODO: Error message" + sanity_check (given_back.ty = ref_ty) meta; + sanity_check (child.ty = ref_ty) meta | AProjSharedBorrow _, RShared -> () | _ -> craise meta "Inconsistent context") | ALoan lc, aty -> ( @@ -599,54 +599,54 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | AMutLoan (bid, child_av) | AIgnoredMutLoan (Some bid, child_av) -> ( let borrowed_aty = aloan_get_expected_child_type aty in - cassert (child_av.ty = borrowed_aty) meta "TODO: Error message"; + sanity_check (child_av.ty = borrowed_aty) meta; (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> - cassert (bv.ty = Substitute.erase_regions borrowed_aty) meta "TODO: Error message" + sanity_check (bv.ty = Substitute.erase_regions borrowed_aty) meta | Abstract (AMutBorrow (_, sv)) -> - cassert ( + sanity_check ( Substitute.erase_regions sv.ty - = Substitute.erase_regions borrowed_aty) meta "TODO: Error message" + = Substitute.erase_regions borrowed_aty) meta | _ -> craise meta "Inconsistent context") | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - cassert (child_av.ty = borrowed_aty) meta "TODO: Error message" + sanity_check (child_av.ty = borrowed_aty) meta | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - cassert (sv.ty = Substitute.erase_regions borrowed_aty) meta "TODO: Error message"; + sanity_check (sv.ty = Substitute.erase_regions borrowed_aty) meta; (* TODO: the type of aloans doesn't make sense, see above *) - cassert (child_av.ty = borrowed_aty) meta "TODO: Error message" + sanity_check (child_av.ty = borrowed_aty) meta | AEndedMutLoan { given_back; child; given_back_meta = _ } | AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } -> let borrowed_aty = aloan_get_expected_child_type aty in - cassert (given_back.ty = borrowed_aty) meta "TODO: Error message"; - cassert (child.ty = borrowed_aty) meta "TODO: Error message" + sanity_check (given_back.ty = borrowed_aty) meta; + sanity_check (child.ty = borrowed_aty) meta | AIgnoredSharedLoan child_av -> - cassert (child_av.ty = aloan_get_expected_child_type aty) meta "TODO: Error message") + sanity_check (child_av.ty = aloan_get_expected_child_type aty) meta) | ASymbolic aproj, ty -> ( let ty1 = Substitute.erase_regions ty in match aproj with | AProjLoans (sv, _) -> let ty2 = Substitute.erase_regions sv.sv_ty in - cassert (ty1 = ty2) meta "TODO: Error message"; + sanity_check (ty1 = ty2) meta; (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - cassert (ty_has_regions_in_set abs.regions sv.sv_ty) meta "The symbolic values should contain regions of interest or they should have been reduced to [] TODO: error message" + sanity_check (ty_has_regions_in_set abs.regions sv.sv_ty) meta | AProjBorrows (sv, proj_ty) -> let ty2 = Substitute.erase_regions sv.sv_ty in - cassert (ty1 = ty2) meta "TODO: Error message"; + sanity_check (ty1 = ty2) meta; (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - cassert (ty_has_regions_in_set abs.regions proj_ty) meta "The symbolic values should contain regions of interest or they should have been reduced to [] TODO: error message" + sanity_check (ty_has_regions_in_set abs.regions proj_ty) meta | AEndedProjLoans (_msv, given_back_ls) -> List.iter (fun (_, proj) -> match proj with - | AProjBorrows (_sv, ty') -> cassert (ty' = ty) meta "TODO: Error message" + | AProjBorrows (_sv, ty') -> sanity_check (ty' = ty) meta | AEndedProjBorrows _ | AIgnoredProjBorrows -> () | _ -> craise meta "Unexpected") given_back_ls @@ -657,7 +657,7 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (lazy ("Erroneous typing:" ^ "\n- raw value: " ^ show_typed_avalue atv ^ "\n- value: " - ^ typed_avalue_to_string meta ctx atv + ^ typed_avalue_to_string ~meta:(Some meta) ctx atv ^ "\n- type: " ^ ty_to_string ctx atv.ty)); craise meta "Erroneous typing"); (* Continue exploring to inspect the subterms *) @@ -766,15 +766,15 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = *) (* A symbolic value can't be both in the regular environment and inside * projectors of borrows in abstractions *) - cassert (info.env_count = 0 || info.aproj_borrows = []) meta "A symbolic value can't be both in the regular environment and inside projectors of borrows in abstractions"; + sanity_check (info.env_count = 0 || info.aproj_borrows = []) meta; (* A symbolic value containing borrows can't be duplicated (i.e., copied): * it must be expanded first *) if ty_has_borrows ctx.type_ctx.type_infos info.ty then - cassert (info.env_count <= 1) meta "A symbolic value containing borrows can't be duplicated (i.e., copied): it must be expanded first"; + sanity_check (info.env_count <= 1) meta; (* A duplicated symbolic value is necessarily primitively copyable *) - cassert (info.env_count <= 1 || ty_is_primitively_copyable info.ty) meta "A duplicated symbolic value should necessarily be primitively copyable"; + sanity_check (info.env_count <= 1 || ty_is_primitively_copyable info.ty) meta; - cassert (info.aproj_borrows = [] || info.aproj_loans <> []) meta "TODO: Error message"; + sanity_check (info.aproj_borrows = [] || info.aproj_loans <> []) meta; (* At the same time: * - check that the loans don't intersect * - compute the set of regions for which we project loans @@ -786,7 +786,7 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = let regions = RegionId.Set.fold (fun rid regions -> - cassert (not (RegionId.Set.mem rid regions)) meta "The loan projectors should contain the region projectors"; + sanity_check (not (RegionId.Set.mem rid regions)) meta; RegionId.Set.add rid regions) regions linfo.regions in @@ -796,8 +796,8 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Check that the union of the loan projectors contains the borrow projections. *) List.iter (fun binfo -> - cassert ( - projection_contains meta info.ty loan_regions binfo.proj_ty binfo.regions) meta "The union of the loan projectors should contain the borrow projections") + sanity_check ( + projection_contains meta info.ty loan_regions binfo.proj_ty binfo.regions) meta) info.aproj_borrows; () in @@ -806,7 +806,7 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = let check_invariants (meta : Meta.meta) (ctx : eval_ctx) : unit = if !Config.sanity_checks then ( - log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string meta ctx)); + log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); check_loans_borrows_relation_invariant meta ctx; check_borrowed_values_invariant meta ctx; check_typing_invariant meta ctx; diff --git a/compiler/Main.ml b/compiler/Main.ml index f860bec8..f8765247 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -113,7 +113,7 @@ let () = Arg.Clear lean_gen_lakefile, " Generate a default lakefile.lean (Lean only)" ); ("-print-llbc", Arg.Set print_llbc, " Print the imported LLBC"); - ("-abort-on-error", Arg.Set fail_hard, " Fail hard (fail on first error) in case of error"); + ("-abort-on-error", Arg.Set fail_hard, "Abort on the first encountered error"); ( "-tuple-nested-proj", Arg.Set use_nested_tuple_projectors, " Use nested projectors for tuples (e.g., (0, 1).snd.fst instead of \ diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index 3ea9c777..c10dbf5d 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -215,11 +215,11 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = inherit [_] map_statement as super method! visit_Loop entered_loop loop = - cassert (not entered_loop) st.meta "TODO: error message"; + cassert (not entered_loop) st.meta "Nested loops are not supported yet"; super#visit_Loop true loop method! visit_Break _ i = - cassert (i = 0) st.meta "TODO: error message"; + cassert (i = 0) st.meta "Breaks to outer loops are not supported yet"; nst.content end in @@ -234,7 +234,7 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = method! visit_Sequence env st1 st2 = match st1.content with | Loop _ -> - cassert (statement_has_no_loop_break_continue st2) st2.meta "TODO: error message"; + sanity_check (statement_has_no_loop_break_continue st2) st2.meta; (replace_breaks_with st1 st2).content | _ -> super#visit_Sequence env st1 st2 end @@ -393,7 +393,6 @@ let remove_shallow_borrows (crate : crate) (f : fun_decl) : fun_decl = let body = filter_visitor#visit_statement () body in (* Check that the filtered variables completely disappeared from the body *) - (* let statement = crate in *) let check_visitor = object inherit [_] iter_statement as super diff --git a/compiler/Print.ml b/compiler/Print.ml index 85e7eaf6..47ae9b79 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -43,12 +43,12 @@ module Values = struct * typed_avalue_to_string. At some point we had done it, because [typed_value] * and [typed_avalue] were instances of the same general type [g_typed_value], * but then we removed this general type because it proved to be a bad idea. *) - let rec typed_value_to_string (meta : Meta.meta) (env : fmt_env) (v : typed_value) : string = + let rec typed_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_value) : string = match v.value with | VLiteral cv -> literal_to_string cv | VAdt av -> ( let field_values = - List.map (typed_value_to_string meta env) av.field_values + List.map (typed_value_to_string~meta:meta env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -83,28 +83,28 @@ module Values = struct | TArray, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" - | _ -> craise meta ("Inconsistent value: " ^ show_typed_value v) + | _ -> craise_opt_meta meta ("Inconsistent value: " ^ show_typed_value v) ) - | _ -> craise meta "Inconsistent typed value") + | _ -> craise_opt_meta meta "Inconsistent typed value") | VBottom -> "⊥ : " ^ ty_to_string env v.ty - | VBorrow bc -> borrow_content_to_string meta env bc - | VLoan lc -> loan_content_to_string meta env lc + | VBorrow bc -> borrow_content_to_string ~meta:meta env bc + | VLoan lc -> loan_content_to_string ~meta:meta env lc | VSymbolic s -> symbolic_value_to_string env s - and borrow_content_to_string (meta : Meta.meta) (env : fmt_env) (bc : borrow_content) : string = + and borrow_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (bc : borrow_content) : string = match bc with | VSharedBorrow bid -> "shared_borrow@" ^ BorrowId.to_string bid | VMutBorrow (bid, tv) -> "mut_borrow@" ^ BorrowId.to_string bid ^ " (" - ^ typed_value_to_string meta env tv + ^ typed_value_to_string ~meta:meta env tv ^ ")" | VReservedMutBorrow bid -> "reserved_borrow@" ^ BorrowId.to_string bid - and loan_content_to_string (meta : Meta.meta) (env : fmt_env) (lc : loan_content) : string = + and loan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (lc : loan_content) : string = match lc with | VSharedLoan (loans, v) -> let loans = BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string meta env v ^ ")" + "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string ~meta:meta env v ^ ")" | VMutLoan bid -> "ml@" ^ BorrowId.to_string bid let abstract_shared_borrow_to_string (env : fmt_env) @@ -142,11 +142,11 @@ module Values = struct | AEndedProjBorrows _mv -> "_" | AIgnoredProjBorrows -> "_" - let rec typed_avalue_to_string (meta : Meta.meta) (env : fmt_env) (v : typed_avalue) : string = + let rec typed_avalue_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_avalue) : string = match v.value with | AAdt av -> ( let field_values = - List.map (typed_avalue_to_string meta env) av.field_values + List.map (typed_avalue_to_string ~meta:meta env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -178,75 +178,75 @@ module Values = struct (* Assumed type *) match (aty, field_values) with | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" - | _ -> craise meta "Inconsistent value") - | _ -> craise meta "Inconsistent typed value") + | _ -> craise_opt_meta meta "Inconsistent value") + | _ -> craise_opt_meta meta "Inconsistent typed value") | ABottom -> "⊥ : " ^ ty_to_string env v.ty - | ABorrow bc -> aborrow_content_to_string meta env bc - | ALoan lc -> aloan_content_to_string meta env lc + | ABorrow bc -> aborrow_content_to_string ~meta:meta env bc + | ALoan lc -> aloan_content_to_string ~meta:meta env lc | ASymbolic s -> aproj_to_string env s | AIgnored -> "_" - and aloan_content_to_string (meta : Meta.meta) (env : fmt_env) (lc : aloan_content) : string = + and aloan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (lc : aloan_content) : string = match lc with | AMutLoan (bid, av) -> "@mut_loan(" ^ BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string meta env av + ^ typed_avalue_to_string ~meta:meta env av ^ ")" | ASharedLoan (loans, v, av) -> let loans = BorrowId.Set.to_string None loans in "@shared_loan(" ^ loans ^ ", " - ^ typed_value_to_string meta env v + ^ typed_value_to_string ~meta:meta env v ^ ", " - ^ typed_avalue_to_string meta env av + ^ typed_avalue_to_string ~meta:meta env av ^ ")" | AEndedMutLoan ml -> "@ended_mut_loan{" - ^ typed_avalue_to_string meta env ml.child + ^ typed_avalue_to_string ~meta:meta env ml.child ^ "; " - ^ typed_avalue_to_string meta env ml.given_back + ^ typed_avalue_to_string ~meta:meta env ml.given_back ^ " }" | AEndedSharedLoan (v, av) -> "@ended_shared_loan(" - ^ typed_value_to_string meta env v + ^ typed_value_to_string ~meta:meta env v ^ ", " - ^ typed_avalue_to_string meta env av + ^ typed_avalue_to_string ~meta:meta env av ^ ")" | AIgnoredMutLoan (opt_bid, av) -> "@ignored_mut_loan(" ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string meta env av + ^ typed_avalue_to_string ~meta:meta env av ^ ")" | AEndedIgnoredMutLoan ml -> "@ended_ignored_mut_loan{ " - ^ typed_avalue_to_string meta env ml.child + ^ typed_avalue_to_string ~meta:meta env ml.child ^ "; " - ^ typed_avalue_to_string meta env ml.given_back + ^ typed_avalue_to_string ~meta:meta env ml.given_back ^ "}" | AIgnoredSharedLoan sl -> - "@ignored_shared_loan(" ^ typed_avalue_to_string meta env sl ^ ")" + "@ignored_shared_loan(" ^ typed_avalue_to_string ~meta:meta env sl ^ ")" - and aborrow_content_to_string (meta : Meta.meta) (env : fmt_env) (bc : aborrow_content) : string + and aborrow_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (bc : aborrow_content) : string = match bc with | AMutBorrow (bid, av) -> "mb@" ^ BorrowId.to_string bid ^ " (" - ^ typed_avalue_to_string meta env av + ^ typed_avalue_to_string ~meta:meta env av ^ ")" | ASharedBorrow bid -> "sb@" ^ BorrowId.to_string bid | AIgnoredMutBorrow (opt_bid, av) -> "@ignored_mut_borrow(" ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string meta env av + ^ typed_avalue_to_string ~meta:meta env av ^ ")" | AEndedMutBorrow (_mv, child) -> - "@ended_mut_borrow(" ^ typed_avalue_to_string meta env child ^ ")" + "@ended_mut_borrow(" ^ typed_avalue_to_string ~meta:meta env child ^ ")" | AEndedIgnoredMutBorrow { child; given_back; given_back_meta = _ } -> "@ended_ignored_mut_borrow{ " - ^ typed_avalue_to_string meta env child + ^ typed_avalue_to_string ~meta:meta env child ^ "; " - ^ typed_avalue_to_string meta env given_back + ^ typed_avalue_to_string ~meta:meta env given_back ^ ")" | AEndedSharedBorrow -> "@ended_shared_borrow" | AProjSharedBorrow sb -> @@ -276,11 +276,11 @@ module Values = struct ^ ")" | Identity -> "Identity" - let abs_to_string (meta : Meta.meta) (env : fmt_env) (verbose : bool) (indent : string) + let abs_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) (indent : string) (indent_incr : string) (abs : abs) : string = let indent2 = indent ^ indent_incr in let avs = - List.map (fun av -> indent2 ^ typed_avalue_to_string meta env av) abs.avalues + List.map (fun av -> indent2 ^ typed_avalue_to_string ~meta:meta env av) abs.avalues in let avs = String.concat ",\n" avs in let kind = @@ -323,7 +323,7 @@ module Contexts = struct | BVar b -> var_binder_to_string env b | BDummy bid -> dummy_var_id_to_string bid - let env_elem_to_string (meta : Meta.meta) (env : fmt_env) (verbose : bool) + let env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) (ev : env_elem) : string = match ev with @@ -332,17 +332,17 @@ module Contexts = struct let ty = if with_var_types then " : " ^ ty_to_string env tv.ty else "" in - indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string meta env tv ^ " ;" - | EAbs abs -> abs_to_string meta env verbose indent indent_incr abs - | EFrame -> craise meta "Can't print a Frame element" + indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string ~meta:meta env tv ^ " ;" + | EAbs abs -> abs_to_string ~meta:meta env verbose indent indent_incr abs + | EFrame -> craise_opt_meta meta "Can't print a Frame element" - let opt_env_elem_to_string (meta : Meta.meta) (env : fmt_env) (verbose : bool) + let opt_env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) (ev : env_elem option) : string = match ev with | None -> indent ^ "..." | Some ev -> - env_elem_to_string meta env verbose with_var_types indent indent_incr ev + env_elem_to_string ~meta:meta env verbose with_var_types indent indent_incr ev (** Filters "dummy" bindings from an environment, to gain space and clarity/ See [env_to_string]. *) @@ -379,7 +379,7 @@ module Contexts = struct "..." to gain space and clarity. [with_var_types]: if true, print the type of the variables *) - let env_to_string (meta : Meta.meta) (filter : bool) (fmt_env : fmt_env) (verbose : bool) + let env_to_string ?(meta : Meta.meta option = None) (filter : bool) (fmt_env : fmt_env) (verbose : bool) (with_var_types : bool) (env : env) : string = let env = if filter then filter_env env else List.map (fun ev -> Some ev) env @@ -388,7 +388,7 @@ module Contexts = struct ^ String.concat "\n" (List.map (fun ev -> - opt_env_elem_to_string meta fmt_env verbose with_var_types " " " " ev) + opt_env_elem_to_string ~meta:meta fmt_env verbose with_var_types " " " " ev) env) ^ "\n}" @@ -468,7 +468,7 @@ module Contexts = struct let frames = split_aux [] [] env in frames - let eval_ctx_to_string_gen (meta : Meta.meta) (verbose : bool) (filter : bool) + let eval_ctx_to_string_gen ?(meta : Meta.meta option = None) (verbose : bool) (filter : bool) (with_var_types : bool) (ctx : eval_ctx) : string = let fmt_env = eval_ctx_to_fmt_env ctx in let ended_regions = RegionId.Set.to_string None ctx.ended_regions in @@ -486,24 +486,24 @@ module Contexts = struct | EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 | EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 | EAbs _ -> num_abs := !num_abs + 1 - | _ -> craise meta "Unreachable") + | _ -> craise_opt_meta meta "Unreachable") f; "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " ^ string_of_int !num_bindings ^ "\n- dummy bindings: " ^ string_of_int !num_dummies ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" - ^ env_to_string meta filter fmt_env verbose with_var_types f + ^ env_to_string ~meta:meta filter fmt_env verbose with_var_types f ^ "\n") frames in "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames ^ " frame(s)\n" ^ String.concat "" frames - let eval_ctx_to_string (meta : Meta.meta) (ctx : eval_ctx) : string = - eval_ctx_to_string_gen meta false true true ctx + let eval_ctx_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) : string = + eval_ctx_to_string_gen ~meta:meta false true true ctx - let eval_ctx_to_string_no_filter (meta : Meta.meta) (ctx : eval_ctx) : string = - eval_ctx_to_string_gen meta false false true ctx + let eval_ctx_to_string_no_filter ?(meta : Meta.meta option = None) (ctx : eval_ctx) : string = + eval_ctx_to_string_gen ~meta:meta false false true ctx end (** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) @@ -541,22 +541,22 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in trait_instance_id_to_string env x - let borrow_content_to_string (meta : Meta.meta) (ctx : eval_ctx) (bc : borrow_content) : string = + let borrow_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (bc : borrow_content) : string = let env = eval_ctx_to_fmt_env ctx in - borrow_content_to_string meta env bc + borrow_content_to_string ~meta:meta env bc - let loan_content_to_string (meta : Meta.meta) (ctx : eval_ctx) (lc : loan_content) : string = + let loan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (lc : loan_content) : string = let env = eval_ctx_to_fmt_env ctx in - loan_content_to_string meta env lc + loan_content_to_string ~meta:meta env lc - let aborrow_content_to_string (meta : Meta.meta) (ctx : eval_ctx) (bc : aborrow_content) : string + let aborrow_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (bc : aborrow_content) : string = let env = eval_ctx_to_fmt_env ctx in - aborrow_content_to_string meta env bc + aborrow_content_to_string ~meta:meta env bc - let aloan_content_to_string (meta : Meta.meta) (ctx : eval_ctx) (lc : aloan_content) : string = + let aloan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (lc : aloan_content) : string = let env = eval_ctx_to_fmt_env ctx in - aloan_content_to_string meta env lc + aloan_content_to_string ~meta:meta env lc let aproj_to_string (ctx : eval_ctx) (p : aproj) : string = let env = eval_ctx_to_fmt_env ctx in @@ -566,13 +566,13 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in symbolic_value_to_string env sv - let typed_value_to_string (meta : Meta.meta) (ctx : eval_ctx) (v : typed_value) : string = + let typed_value_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (v : typed_value) : string = let env = eval_ctx_to_fmt_env ctx in - typed_value_to_string meta env v + typed_value_to_string ~meta:meta env v - let typed_avalue_to_string (meta : Meta.meta) (ctx : eval_ctx) (v : typed_avalue) : string = + let typed_avalue_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (v : typed_avalue) : string = let env = eval_ctx_to_fmt_env ctx in - typed_avalue_to_string meta env v + typed_avalue_to_string ~meta:meta env v let place_to_string (ctx : eval_ctx) (op : place) : string = let env = eval_ctx_to_fmt_env ctx in @@ -613,13 +613,13 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in trait_impl_to_string env " " " " timpl - let env_elem_to_string (meta : Meta.meta) (ctx : eval_ctx) (indent : string) + let env_elem_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (indent : string) (indent_incr : string) (ev : env_elem) : string = let env = eval_ctx_to_fmt_env ctx in - env_elem_to_string meta env false true indent indent_incr ev + env_elem_to_string ~meta:meta env false true indent indent_incr ev - let abs_to_string (meta : Meta.meta) (ctx : eval_ctx) (indent : string) (indent_incr : string) + let abs_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (indent : string) (indent_incr : string) (abs : abs) : string = let env = eval_ctx_to_fmt_env ctx in - abs_to_string meta env false indent indent_incr abs + abs_to_string ~meta:meta env false indent indent_incr abs end diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 3008e1bd..6ef87194 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -351,7 +351,7 @@ let adt_field_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) (** TODO: we don't need a general function anymore (it is now only used for patterns) *) -let adt_g_value_to_string (meta : Meta.meta) (env : fmt_env) (value_to_string : 'v -> string) +let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (value_to_string : 'v -> string) (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in @@ -386,50 +386,50 @@ let adt_g_value_to_string (meta : Meta.meta) (env : fmt_env) (value_to_string : match aty with | TState | TRawPtr _ -> (* This type is opaque: we can't get there *) - craise meta "Unreachable" + craise_opt_meta meta "Unreachable" | TResult -> let variant_id = Option.get variant_id in if variant_id = result_return_id then match field_values with | [ v ] -> "@Result::Return " ^ v - | _ -> craise meta "Result::Return takes exactly one value" + | _ -> craise_opt_meta meta "Result::Return takes exactly one value" else if variant_id = result_fail_id then match field_values with | [ v ] -> "@Result::Fail " ^ v - | _ -> craise meta "Result::Fail takes exactly one value" + | _ -> craise_opt_meta meta "Result::Fail takes exactly one value" else - craise meta "Unreachable: improper variant id for result type" + craise_opt_meta meta "Unreachable: improper variant id for result type" | TError -> - cassert (field_values = []) meta "TODO: error message"; + cassert_opt_meta (field_values = []) meta "TODO: error message"; let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" - else craise meta "Unreachable: improper variant id for error type" + else craise_opt_meta meta "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then ( - cassert (field_values = []) meta "TODO: error message"; + cassert_opt_meta (field_values = []) meta "TODO: error message"; "@Fuel::Zero") else if variant_id = fuel_succ_id then match field_values with | [ v ] -> "@Fuel::Succ " ^ v - | _ -> craise meta "@Fuel::Succ takes exactly one value" - else craise meta "Unreachable: improper variant id for fuel type" + | _ -> craise_opt_meta meta "@Fuel::Succ takes exactly one value" + else craise_opt_meta meta "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr -> - cassert (variant_id = None) meta "TODO: error message"; + cassert_opt_meta (variant_id = None) meta "TODO: error message"; let field_values = List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values in let id = assumed_ty_to_string aty in id ^ " [" ^ String.concat "; " field_values ^ "]") | _ -> - craise + craise_opt_meta meta ("Inconsistently typed value: expected ADT type but found:" ^ "\n- ty: " ^ ty_to_string env false ty ^ "\n- variant_id: " ^ Print.option_to_string VariantId.to_string variant_id) -let rec typed_pattern_to_string (meta : Meta.meta) (env : fmt_env) (v : typed_pattern) : string = +let rec typed_pattern_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_pattern) : string = match v.value with | PatConstant cv -> literal_to_string cv | PatVar (v, None) -> var_to_string env v @@ -440,8 +440,8 @@ let rec typed_pattern_to_string (meta : Meta.meta) (env : fmt_env) (v : typed_pa ^ ")" | PatDummy -> "_" | PatAdt av -> - adt_g_value_to_string meta env - (typed_pattern_to_string meta env) + adt_g_value_to_string ~meta:meta env + (typed_pattern_to_string ~meta:meta env) av.variant_id av.field_values v.ty let fun_sig_to_string (env : fmt_env) (sg : fun_sig) : string = @@ -522,7 +522,7 @@ let fun_or_op_id_to_string (env : fmt_env) (fun_id : fun_or_op_id) : string = binop_to_string binop ^ "<" ^ integer_type_to_string int_ty ^ ">" (** [inside]: controls the introduction of parentheses *) -let rec texpression_to_string (metadata : Meta.meta) (env : fmt_env) (inside : bool) (indent : string) +let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) (inside : bool) (indent : string) (indent_incr : string) (e : texpression) : string = match e.e with | Var var_id -> var_id_to_string env var_id @@ -532,22 +532,22 @@ let rec texpression_to_string (metadata : Meta.meta) (env : fmt_env) (inside : b (* Recursively destruct the app, to have a pair (app, arguments list) *) let app, args = destruct_apps e in (* Convert to string *) - app_to_string metadata env inside indent indent_incr app args + app_to_string ~meta:metadata env inside indent indent_incr app args | Lambda _ -> let xl, e = destruct_lambdas e in - let e = lambda_to_string metadata env indent indent_incr xl e in + let e = lambda_to_string ~meta:metadata env indent indent_incr xl e in if inside then "(" ^ e ^ ")" else e | Qualif _ -> (* Qualifier without arguments *) - app_to_string metadata env inside indent indent_incr e [] + app_to_string ~meta:metadata env inside indent indent_incr e [] | Let (monadic, lv, re, e) -> - let e = let_to_string metadata env indent indent_incr monadic lv re e in + let e = let_to_string ~meta:metadata env indent indent_incr monadic lv re e in if inside then "(" ^ e ^ ")" else e | Switch (scrutinee, body) -> - let e = switch_to_string metadata env indent indent_incr scrutinee body in + let e = switch_to_string ~meta:metadata env indent indent_incr scrutinee body in if inside then "(" ^ e ^ ")" else e | Loop loop -> - let e = loop_to_string metadata env indent indent_incr loop in + let e = loop_to_string ~meta:metadata env indent indent_incr loop in if inside then "(" ^ e ^ ")" else e | StructUpdate supd -> ( let s = @@ -566,7 +566,7 @@ let rec texpression_to_string (metadata : Meta.meta) (env : fmt_env) (inside : b (fun (fid, fe) -> let field = FieldId.nth field_names fid in let fe = - texpression_to_string metadata env false indent2 indent_incr fe + texpression_to_string ~metadata:metadata env false indent2 indent_incr fe in "\n" ^ indent1 ^ field ^ " := " ^ fe ^ ";") supd.updates @@ -577,21 +577,21 @@ let rec texpression_to_string (metadata : Meta.meta) (env : fmt_env) (inside : b let fields = List.map (fun (_, fe) -> - texpression_to_string metadata env false indent2 indent_incr fe) + texpression_to_string ~metadata:metadata env false indent2 indent_incr fe) supd.updates in "[ " ^ String.concat ", " fields ^ " ]" - | _ -> craise metadata "Unexpected") + | _ -> craise_opt_meta metadata "Unexpected") | Meta (meta, e) -> ( - let meta_s = emeta_to_string metadata env meta in - let e = texpression_to_string metadata env inside indent indent_incr e in + let meta_s = emeta_to_string ~metadata:metadata env meta in + let e = texpression_to_string ~metadata:metadata env inside indent indent_incr e in match meta with | Assignment _ | SymbolicAssignments _ | SymbolicPlaces _ | Tag _ -> let e = meta_s ^ "\n" ^ indent ^ e in if inside then "(" ^ e ^ ")" else e | MPlace _ -> "(" ^ meta_s ^ " " ^ e ^ ")") -and app_to_string (meta : Meta.meta) (env : fmt_env) (inside : bool) (indent : string) +and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bool) (indent : string) (indent_incr : string) (app : texpression) (args : texpression list) : string = (* There are two possibilities: either the [app] is an instantiated, @@ -611,13 +611,13 @@ and app_to_string (meta : Meta.meta) (env : fmt_env) (inside : bool) (indent : s (global_decl_id_to_string env global_id, generics) | AdtCons adt_cons_id -> let variant_s = - adt_variant_to_string ~meta:(Some meta) env adt_cons_id.adt_id + adt_variant_to_string ~meta:meta env adt_cons_id.adt_id adt_cons_id.variant_id in (ConstStrings.constructor_prefix ^ variant_s, []) | Proj { adt_id; field_id } -> - let adt_s = adt_variant_to_string ~meta:(Some meta) env adt_id None in - let field_s = adt_field_to_string ~meta:(Some meta) env adt_id field_id in + let adt_s = adt_variant_to_string ~meta:meta env adt_id None in + let field_s = adt_field_to_string ~meta:meta env adt_id field_id in (* Adopting an F*-like syntax *) (ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s, []) | TraitConst (trait_ref, const_name) -> @@ -627,7 +627,7 @@ and app_to_string (meta : Meta.meta) (env : fmt_env) (inside : bool) (indent : s | _ -> (* "Regular" expression case *) let inside = args <> [] || (args = [] && inside) in - (texpression_to_string meta env inside indent indent_incr app, []) + (texpression_to_string ~metadata:meta env inside indent indent_incr app, []) in (* Convert the arguments. * The arguments are expressions, so indentation might get weird... (though @@ -635,7 +635,7 @@ and app_to_string (meta : Meta.meta) (env : fmt_env) (inside : bool) (indent : s let arg_to_string = let inside = true in let indent1 = indent ^ indent_incr in - texpression_to_string meta env inside indent1 indent_incr + texpression_to_string ~metadata:meta env inside indent1 indent_incr in let args = List.map arg_to_string args in let all_args = List.append generics args in @@ -646,31 +646,31 @@ and app_to_string (meta : Meta.meta) (env : fmt_env) (inside : bool) (indent : s (* Add parentheses *) if all_args <> [] && inside then "(" ^ e ^ ")" else e -and lambda_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_incr : string) +and lambda_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) (xl : typed_pattern list) (e : texpression) : string = - let xl = List.map (typed_pattern_to_string meta env) xl in - let e = texpression_to_string meta env false indent indent_incr e in + let xl = List.map (typed_pattern_to_string ~meta:meta env) xl in + let e = texpression_to_string ~metadata:meta env false indent indent_incr e in "λ " ^ String.concat " " xl ^ ". " ^ e -and let_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_incr : string) +and let_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) (monadic : bool) (lv : typed_pattern) (re : texpression) (e : texpression) : string = let indent1 = indent ^ indent_incr in let inside = false in - let re = texpression_to_string meta env inside indent1 indent_incr re in - let e = texpression_to_string meta env inside indent indent_incr e in - let lv = typed_pattern_to_string meta env lv in + let re = texpression_to_string ~metadata:meta env inside indent1 indent_incr re in + let e = texpression_to_string ~metadata:meta env inside indent indent_incr e in + let lv = typed_pattern_to_string ~meta:meta env lv in if monadic then lv ^ " <-- " ^ re ^ ";\n" ^ indent ^ e else "let " ^ lv ^ " = " ^ re ^ " in\n" ^ indent ^ e -and switch_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_incr : string) +and switch_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) (scrutinee : texpression) (body : switch_body) : string = let indent1 = indent ^ indent_incr in (* Printing can mess up on the scrutinee, because it is an expression - but * in most situations it will be a value or a function call, so it should be * ok*) - let scrut = texpression_to_string meta env true indent1 indent_incr scrutinee in - let e_to_string = texpression_to_string meta env false indent1 indent_incr in + let scrut = texpression_to_string ~metadata:meta env true indent1 indent_incr scrutinee in + let e_to_string = texpression_to_string ~metadata:meta env false indent1 indent_incr in match body with | If (e_true, e_false) -> let e_true = e_to_string e_true in @@ -679,13 +679,13 @@ and switch_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (inden ^ indent ^ "else\n" ^ indent1 ^ e_false | Match branches -> let branch_to_string (b : match_branch) : string = - let pat = typed_pattern_to_string meta env b.pat in + let pat = typed_pattern_to_string ~meta:meta env b.pat in indent ^ "| " ^ pat ^ " ->\n" ^ indent1 ^ e_to_string b.branch in let branches = List.map branch_to_string branches in "match " ^ scrut ^ " with\n" ^ String.concat "\n" branches -and loop_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_incr : string) +and loop_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) (loop : loop) : string = let indent1 = indent ^ indent_incr in let indent2 = indent1 ^ indent_incr in @@ -696,17 +696,17 @@ and loop_to_string (meta : Meta.meta) (env : fmt_env) (indent : string) (indent_ in let output_ty = "output_ty: " ^ ty_to_string env false loop.output_ty in let fun_end = - texpression_to_string meta env false indent2 indent_incr loop.fun_end + texpression_to_string ~metadata:meta env false indent2 indent_incr loop.fun_end in let loop_body = - texpression_to_string meta env false indent2 indent_incr loop.loop_body + texpression_to_string ~metadata:meta env false indent2 indent_incr loop.loop_body in "loop {\n" ^ indent1 ^ loop_inputs ^ "\n" ^ indent1 ^ output_ty ^ "\n" ^ indent1 ^ "fun_end: {\n" ^ indent2 ^ fun_end ^ "\n" ^ indent1 ^ "}\n" ^ indent1 ^ "loop_body: {\n" ^ indent2 ^ loop_body ^ "\n" ^ indent1 ^ "}\n" ^ indent ^ "}" -and emeta_to_string (metadata : Meta.meta) (env : fmt_env) (meta : emeta) : string = +and emeta_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) (meta : emeta) : string = let meta = match meta with | Assignment (lp, rv, rp) -> @@ -716,14 +716,14 @@ and emeta_to_string (metadata : Meta.meta) (env : fmt_env) (meta : emeta) : stri | Some rp -> " [@src=" ^ mplace_to_string env rp ^ "]" in "@assign(" ^ mplace_to_string env lp ^ " := " - ^ texpression_to_string metadata env false "" "" rv + ^ texpression_to_string ~metadata:metadata env false "" "" rv ^ rp ^ ")" | SymbolicAssignments info -> let infos = List.map (fun (var_id, rv) -> VarId.to_string var_id ^ " == " - ^ texpression_to_string metadata env false "" "" rv) + ^ texpression_to_string ~metadata:metadata env false "" "" rv) info in let infos = String.concat ", " infos in @@ -756,5 +756,5 @@ let fun_decl_to_string (env : fmt_env) (def : fun_decl) : string = if inputs = [] then indent else " fun " ^ String.concat " " inputs ^ " ->\n" ^ indent in - let body = texpression_to_string def.meta env inside indent indent body.body in + let body = texpression_to_string ~metadata:(Some def.meta) env inside indent indent body.body in "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index d7423441..1df7176d 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -222,7 +222,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = (* Register a variable for constraints propagation - used when an variable is * introduced (left-hand side of a left binding) *) let register_var (ctx : pn_ctx) (v : var) : pn_ctx = - cassert (not (VarId.Map.mem v.id ctx.pure_vars)) def.meta "TODO: error message"; + sanity_check (not (VarId.Map.mem v.id ctx.pure_vars)) def.meta; match v.basename with | None -> ctx | Some name -> @@ -1204,7 +1204,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = let num_fields = List.length fields in (* In order to simplify, there must be as many arguments as * there are fields *) - cassert (num_fields > 0) def.meta "The number of fields is not > 0"; + sanity_check (num_fields > 0) def.meta; if num_fields = List.length args then (* We now need to check that all the arguments are of the form: * [x.field] for some variable [x], and where the projection @@ -1572,7 +1572,7 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = let arg, args = Collections.List.pop args in mk_apps def.meta arg args | BoxFree -> - cassert (args = []) def.meta "TODO: error message"; + sanity_check (args = []) def.meta; mk_unit_rvalue | SliceIndexShared | SliceIndexMut | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut @@ -1767,7 +1767,7 @@ let unfold_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = (* TODO: this information should be computed in SymbolicToPure and * store in an enum ("monadic" should be an enum, not a bool). *) let re_ty = Option.get (opt_destruct_result def.meta re.ty) in - cassert (lv.ty = re_ty) def.meta "TODO: error message"; + sanity_check (lv.ty = re_ty) def.meta; let err_vid = fresh_id () in let err_var : var = { @@ -1981,7 +1981,6 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : (List.concat (List.map (fun { f; loops } -> [ f :: loops ]) transl)) in let subgroups = ReorderDecls.group_reorder_fun_decls all_decls in -(* TODO meta or not meta ? *) log#ldebug (lazy ("filter_loop_inputs: all_decls:\n\n" @@ -2021,7 +2020,7 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : ^ String.concat ", " (List.map (var_to_string ctx) inputs_prefix) ^ "\n")); let inputs_set = VarId.Set.of_list (List.map var_get_id inputs_prefix) in - cassert (Option.is_some decl.loop_id) decl.meta "TODO: error message"; + sanity_check (Option.is_some decl.loop_id) decl.meta; let fun_id = (E.FRegular decl.def_id, decl.loop_id) in @@ -2173,7 +2172,7 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : in let fwd_info = { fwd_info; effect_info; ignore_output } in - cassert (fun_sig_info_is_wf fwd_info) decl.meta "TODO: error message"; + sanity_check (fun_sig_info_is_wf fwd_info) decl.meta; let signature = { generics; diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 6bc11a7c..d2fa57ae 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -15,9 +15,9 @@ let get_adt_field_types (meta : Meta.meta) (type_decls : type_decl TypeDeclId.Ma match type_id with | TTuple -> (* Tuple *) - cassert (generics.const_generics = []) meta "TODO: error message"; - cassert (generics.trait_refs = []) meta "TODO: error message"; - cassert (variant_id = None) meta "TODO: error message"; + sanity_check (generics.const_generics = []) meta; + sanity_check (generics.trait_refs = []) meta; + sanity_check (variant_id = None) meta; generics.types | TAdtId def_id -> (* "Regular" ADT *) @@ -37,10 +37,10 @@ let get_adt_field_types (meta : Meta.meta) (type_decls : type_decl TypeDeclId.Ma else craise meta "Unreachable: improper variant id for result type" | TError -> - cassert (generics = empty_generic_args) meta "TODO: error message"; + sanity_check (generics = empty_generic_args) meta; let variant_id = Option.get variant_id in - cassert ( - variant_id = error_failure_id || variant_id = error_out_of_fuel_id) meta "TODO: error message"; + sanity_check ( + variant_id = error_failure_id || variant_id = error_out_of_fuel_id) meta; [] | TFuel -> let variant_id = Option.get variant_id in @@ -64,7 +64,7 @@ type tc_ctx = { let check_literal (meta : Meta.meta) (v : literal) (ty : literal_type) : unit = match (ty, v) with - | TInteger int_ty, VScalar sv -> cassert (int_ty = sv.int_ty) meta "TODO: error message" + | TInteger int_ty, VScalar sv -> sanity_check (int_ty = sv.int_ty) meta | TBool, VBool _ | TChar, VChar _ -> () | _ -> craise meta "Inconsistent type" @@ -76,7 +76,7 @@ let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) (v : typed_pattern ctx | PatDummy -> ctx | PatVar (var, _) -> - cassert (var.ty = v.ty) meta "TODO: error message"; + sanity_check (var.ty = v.ty) meta; let env = VarId.Map.add var.id var.ty ctx.env in { ctx with env } | PatAdt av -> @@ -110,21 +110,21 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : * we use a locally nameless representation *) match VarId.Map.find_opt var_id ctx.env with | None -> () - | Some ty -> cassert (ty = e.ty) meta "TODO: error message") + | Some ty -> sanity_check (ty = e.ty) meta) | CVar cg_id -> let ty = T.ConstGenericVarId.Map.find cg_id ctx.const_generics in - cassert (ty = e.ty) meta "TODO: error message" + sanity_check (ty = e.ty) meta | Const cv -> check_literal meta cv (ty_as_literal meta e.ty) | App (app, arg) -> let input_ty, output_ty = destruct_arrow meta app.ty in - cassert (input_ty = arg.ty) meta "TODO: error message"; - cassert (output_ty = e.ty) meta "TODO: error message"; + sanity_check (input_ty = arg.ty) meta; + sanity_check (output_ty = e.ty) meta; check_texpression meta ctx app; check_texpression meta ctx arg | Lambda (pat, body) -> let pat_ty, body_ty = destruct_arrow meta e.ty in - cassert (pat.ty = pat_ty) meta "TODO: error message"; - cassert (body.ty = body_ty) meta "TODO: error message"; + sanity_check (pat.ty = pat_ty) meta; + sanity_check (body.ty = body_ty) meta; (* Check the pattern and register the introduced variables at the same time *) let ctx = check_typed_pattern meta ctx pat in check_texpression meta ctx body @@ -139,8 +139,8 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : let adt_ty, field_ty = destruct_arrow meta e.ty in let adt_id, adt_generics = ty_as_adt meta adt_ty in (* Check the ADT type *) - cassert (adt_id = proj_adt_id) meta "TODO: error message"; - cassert (adt_generics = qualif.generics) meta "TODO: error message"; + sanity_check (adt_id = proj_adt_id) meta; + sanity_check (adt_generics = qualif.generics) meta; (* Retrieve and check the expected field type *) let variant_id = None in let expected_field_tys = @@ -148,23 +148,23 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : qualif.generics in let expected_field_ty = FieldId.nth expected_field_tys field_id in - cassert (expected_field_ty = field_ty) meta "TODO: error message" + sanity_check (expected_field_ty = field_ty) meta | AdtCons id -> ( let expected_field_tys = get_adt_field_types meta ctx.type_decls id.adt_id id.variant_id qualif.generics in let field_tys, adt_ty = destruct_arrows e.ty in - cassert (expected_field_tys = field_tys) meta "TODO: error message"; + sanity_check (expected_field_tys = field_tys) meta; match adt_ty with | TAdt (type_id, generics) -> - cassert (type_id = id.adt_id) meta "TODO: error message"; - cassert (generics = qualif.generics) meta "TODO: error message" + sanity_check (type_id = id.adt_id) meta; + sanity_check (generics = qualif.generics) meta | _ -> craise meta "Unreachable")) | Let (monadic, pat, re, e_next) -> let expected_pat_ty = if monadic then destruct_result meta re.ty else re.ty in - cassert (pat.ty = expected_pat_ty) meta "TODO: error message"; - cassert (e.ty = e_next.ty) meta "TODO: error message"; + sanity_check (pat.ty = expected_pat_ty) meta; + sanity_check (e.ty = e_next.ty) meta; (* Check the right-expression *) check_texpression meta ctx re; (* Check the pattern and register the introduced variables at the same time *) @@ -175,20 +175,20 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : check_texpression meta ctx scrut; match switch_body with | If (e_then, e_else) -> - cassert (scrut.ty = TLiteral TBool) meta "TODO: error message"; - cassert (e_then.ty = e.ty) meta "TODO: error message"; - cassert (e_else.ty = e.ty) meta "TODO: error message"; + sanity_check (scrut.ty = TLiteral TBool) meta; + sanity_check (e_then.ty = e.ty) meta; + sanity_check (e_else.ty = e.ty) meta; check_texpression meta ctx e_then; check_texpression meta ctx e_else | Match branches -> let check_branch (br : match_branch) : unit = - cassert (br.pat.ty = scrut.ty) meta "TODO: error message"; + sanity_check (br.pat.ty = scrut.ty) meta; let ctx = check_typed_pattern meta ctx br.pat in check_texpression meta ctx br.branch in List.iter check_branch branches) | Loop loop -> - cassert (loop.fun_end.ty = e.ty) meta "TODO: error message"; + sanity_check (loop.fun_end.ty = e.ty) meta; check_texpression meta ctx loop.fun_end; check_texpression meta ctx loop.loop_body | StructUpdate supd -> ( @@ -196,11 +196,11 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : (if Option.is_some supd.init then match VarId.Map.find_opt (Option.get supd.init) ctx.env with | None -> () - | Some ty -> cassert (ty = e.ty) meta "TODO: error message"); + | Some ty -> sanity_check (ty = e.ty) meta); (* Check the fields *) (* Retrieve and check the expected field type *) let adt_id, adt_generics = ty_as_adt meta e.ty in - cassert (adt_id = supd.struct_id) meta "TODO: error message"; + sanity_check (adt_id = supd.struct_id) meta; (* The id can only be: a custom type decl or an array *) match adt_id with | TAdtId _ -> @@ -211,7 +211,7 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : List.iter (fun ((fid, fe) : _ * texpression) -> let expected_field_ty = FieldId.nth expected_field_tys fid in - cassert (expected_field_ty = fe.ty) meta "TODO: error message"; + sanity_check (expected_field_ty = fe.ty) meta; check_texpression meta ctx fe) supd.updates | TAssumed TArray -> @@ -220,10 +220,10 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : in List.iter (fun ((_, fe) : _ * texpression) -> - cassert (expected_field_ty = fe.ty) meta "TODO: error message"; + sanity_check (expected_field_ty = fe.ty) meta; check_texpression meta ctx fe) supd.updates | _ -> craise meta "Unexpected") | Meta (_, e_next) -> - cassert (e_next.ty = e.ty) meta "TODO: error message"; + sanity_check (e_next.ty = e.ty) meta; check_texpression meta ctx e_next diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 0f9c2dfe..cce70382 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -78,7 +78,7 @@ let fun_sig_info_is_wf (info : fun_sig_info) : bool = let dest_arrow_ty (meta : Meta.meta) (ty : ty) : ty * ty = match ty with | TArrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) - | _ -> craise meta "Unreachable" + | _ -> craise meta "Not an arrow type" let compute_literal_type (cv : literal) : literal_type = match cv with @@ -237,7 +237,7 @@ let is_var (e : texpression) : bool = match e.e with Var _ -> true | _ -> false let as_var (meta : Meta.meta) (e : texpression) : VarId.id = - match e.e with Var v -> v | _ -> craise meta "Unreachable" + match e.e with Var v -> v | _ -> craise meta "Not a var" let is_cvar (e : texpression) : bool = match e.e with CVar _ -> true | _ -> false @@ -251,7 +251,7 @@ let is_const (e : texpression) : bool = let ty_as_adt (meta : Meta.meta) (ty : ty) : type_id * generic_args = match ty with | TAdt (id, generics) -> (id, generics) - | _ -> craise meta "Unreachable" + | _ -> craise meta "Not an ADT" (** Remove the external occurrences of {!Meta} *) let rec unmeta (e : texpression) : texpression = @@ -294,7 +294,7 @@ let destruct_lets_no_interleave (meta : Meta.meta) (e : texpression) : let m = match e.e with | Let (monadic, _, _, _) -> monadic - | _ -> craise meta "Unreachable" + | _ -> craise meta "Not a let-binding" in (* Destruct the rest *) let rec destruct_lets (e : texpression) : @@ -323,12 +323,11 @@ let destruct_apps (e : texpression) : texpression * texpression list = (** Make an [App (app, arg)] expression *) let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : texpression = let raise_or_return msg = - if !Config.fail_hard then craise meta msg - else - let e = App (app, arg) in - (* Dummy type - TODO: introduce an error type *) - let ty = app.ty in - { e; ty } + save_error (Some meta) msg; + let e = App (app, arg) in + (* Dummy type - TODO: introduce an error type *) + let ty = app.ty in + { e; ty } in match app.ty with | TArrow (ty0, ty1) -> @@ -371,8 +370,8 @@ let opt_destruct_function_call (e : texpression) : let opt_destruct_result (meta : Meta.meta) (ty : ty) : ty option = match ty with | TAdt (TAssumed TResult, generics) -> - cassert (generics.const_generics = []) meta "TODO: Error message"; - cassert (generics.trait_refs = []) meta "TODO: Error message"; + sanity_check (generics.const_generics = []) meta; + sanity_check (generics.trait_refs = []) meta; Some (Collections.List.to_cons_nil generics.types) | _ -> None @@ -381,8 +380,8 @@ let destruct_result (meta : Meta.meta) (ty : ty) : ty = Option.get (opt_destruct let opt_destruct_tuple (meta : Meta.meta) (ty : ty) : ty list option = match ty with | TAdt (TTuple, generics) -> - cassert (generics.const_generics = []) meta "TODO: Error message"; - cassert (generics.trait_refs = []) meta "TODO: Error message"; + sanity_check (generics.const_generics = []) meta; + sanity_check (generics.trait_refs = []) meta; Some generics.types | _ -> None diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index f4e2ff35..a4d66854 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -44,7 +44,7 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty (fun_decls : fun_decl FunDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) - (trait_impls : trait_impl TraitImplId.Map.t) (* ?meta *) (fun_name : string) + (trait_impls : trait_impl TraitImplId.Map.t) (fun_name : string) (sg : fun_sig) : region_var_groups = log#ldebug (lazy (__FUNCTION__ ^ ": " ^ fun_name)); (* Initialize a normalization context (we may need to normalize some @@ -174,13 +174,13 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty | TTraitType (trait_ref, _) -> (* The trait should reference a clause, and not an implementation (otherwise it should have been normalized) *) - cassert_opt_meta ( - AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id) meta "The trait should reference a clause, and not an implementation (otherwise it should have been normalized)"; + sanity_check_opt_meta ( + AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id) meta; (* We have nothing to do *) () | TArrow (regions, inputs, output) -> (* TODO: *) - cassert_opt_meta (regions = []) meta "Regions should be empty"; + cassert_opt_meta (regions = []) meta "We don't support arrow types with locally quantified regions"; (* We can ignore the outer regions *) List.iter (explore_ty []) (output :: inputs) and explore_generics (outer : region list) (generics : generic_args) = @@ -223,7 +223,7 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty (SccId.Map.bindings sccs.sccs) in (* The SCC should only contain the 'static *) - cassert_opt_meta (static_scc = [ RStatic ]) meta "The SCC should only contain the 'static"; + sanity_check_opt_meta (static_scc = [ RStatic ]) meta; (* Remove the group as well as references to this group from the other SCCs *) let { sccs; scc_deps } = sccs in diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index a35fdbf3..14cda863 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -80,9 +80,9 @@ let ctx_adt_value_get_instantiated_field_types (meta : Meta.meta) (ctx : eval_ct | TAssumed aty -> ( match aty with | TBox -> - cassert (generics.regions = []) meta "Regions should be empty TODO: error message"; - cassert (List.length generics.types = 1) meta "Too many types TODO: error message"; - cassert (generics.const_generics = []) meta "const_generics should be empty TODO: error message"; + sanity_check (generics.regions = []) meta; + sanity_check (List.length generics.types = 1) meta; + sanity_check (generics.const_generics = []) meta; generics.types | TArray | TSlice | TStr -> (* Those types don't have fields *) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 46058a9a..e60d6870 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -325,7 +325,7 @@ let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = let typed_value_to_string (ctx : bs_ctx) (v : V.typed_value) : string = let env = bs_ctx_to_fmt_env ctx in - Print.Values.typed_value_to_string ctx.fun_decl.meta env v + Print.Values.typed_value_to_string ~meta:(Some ctx.fun_decl.meta) env v let pure_ty_to_string (ctx : bs_ctx) (ty : ty) : string = let env = bs_ctx_to_pure_fmt_env ctx in @@ -349,7 +349,7 @@ let pure_type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.texpression_to_string ctx.fun_decl.meta env false "" " " e + PrintPure.texpression_to_string ~metadata:(Some ctx.fun_decl.meta) env false "" " " e let fun_id_to_string (ctx : bs_ctx) (id : A.fun_id) : string = let env = bs_ctx_to_fmt_env ctx in @@ -363,9 +363,9 @@ let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = let env = bs_ctx_to_pure_fmt_env ctx in PrintPure.fun_decl_to_string env def -let typed_pattern_to_string (meta : Meta.meta) (ctx : bs_ctx) (p : Pure.typed_pattern) : string = +let typed_pattern_to_string ?(meta : Meta.meta option = None) (ctx : bs_ctx) (p : Pure.typed_pattern) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.typed_pattern_to_string meta env p + PrintPure.typed_pattern_to_string ~meta:meta env p let ctx_get_effect_info_for_bid (ctx : bs_ctx) (bid : RegionGroupId.id option) : fun_effect_info = @@ -384,7 +384,7 @@ let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = let verbose = false in let indent = "" in let indent_incr = " " in - Print.Values.abs_to_string ctx.fun_decl.meta env verbose indent indent_incr abs + Print.Values.abs_to_string ~meta:(Some ctx.fun_decl.meta) env verbose indent indent_incr abs let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : T.type_decl = @@ -478,7 +478,7 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = | TTraitType (trait_ref, type_name) -> let trait_ref = translate_strait_ref meta trait_ref in TTraitType (trait_ref, type_name) - | TArrow _ -> craise meta "TODO" + | TArrow _ -> craise meta "TODO: error message" and translate_sgeneric_args (meta : Meta.meta) (generics : T.generic_args) : generic_args = translate_generic_args meta (translate_sty meta) generics @@ -555,7 +555,7 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : let name = Print.Types.name_to_string env def.name in let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) - cassert (regions = []) def.meta "Translating types with regions is not supported yet"; + cassert (regions = []) def.meta "ADTs containing borrows are not supported yet"; let trait_clauses = List.map (translate_trait_clause def.meta) trait_clauses in let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.meta def.T.kind in @@ -620,7 +620,7 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) (ty : T.ty not (List.exists (TypesUtils.ty_has_borrows type_infos) - generics.types)) meta "General parametricity is not supported yet"; + generics.types)) meta "ADTs containing borrows are not supported yet"; match t_generics.types with | [ bty ] -> bty | _ -> @@ -640,7 +640,7 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) (ty : T.ty | TTraitType (trait_ref, type_name) -> let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in TTraitType (trait_ref, type_name) - | TArrow _ -> craise meta "TODO" + | TArrow _ -> craise meta "TODO: error message" and translate_fwd_generic_args (meta : Meta.meta) (type_infos : type_infos) (generics : T.generic_args) : generic_args = @@ -701,7 +701,7 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) else None | TAssumed TBox -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) - cassert (not (TypesUtils.ty_has_borrows type_infos ty)) meta "ADTs with borrows are not supported yet"; + cassert (not (TypesUtils.ty_has_borrows type_infos ty)) meta "ADTs containing borrows are not supported yet"; (* Eliminate the box *) match generics.types with | [ bty ] -> translate bty @@ -744,7 +744,7 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in Some (TTraitType (trait_ref, type_name)) else None - | TArrow _ -> craise meta "TODO" + | TArrow _ -> craise meta "TODO: error message" (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) @@ -794,7 +794,7 @@ let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) (back_funs : texpression option RegionGroupId.Map.t option) (ctx : bs_ctx) : bs_ctx = let calls = ctx.calls in - cassert (not (V.FunCallId.Map.mem call_id calls)) ctx.fun_decl.meta "TODO: error message"; + sanity_check (not (V.FunCallId.Map.mem call_id calls)) ctx.fun_decl.meta; let info = { forward; forward_inputs = args; back_funs } in let calls = V.FunCallId.Map.add call_id info calls in { ctx with calls } @@ -816,7 +816,7 @@ let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) let calls = V.FunCallId.Map.add call_id info ctx.calls in (* Insert the abstraction in the abstractions map *) let abstractions = ctx.abstractions in - cassert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) ctx.fun_decl.meta "This abstraction should not be in the abstractions map"; + sanity_check (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) ctx.fun_decl.meta; let abstractions = V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions in @@ -896,7 +896,7 @@ let compute_raw_fun_effect_info (meta : Meta.meta) (fun_infos : fun_info A.FunD is_rec = info.is_rec || Option.is_some lid; } | FunId (FAssumed aid) -> - cassert (lid = None) meta "TODO: error message"; + sanity_check (lid = None) meta; { can_fail = Assumed.assumed_fun_can_fail aid; stateful_group = false; @@ -926,7 +926,7 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) (* This is necessarily for the current function *) match fun_id with | FunId (FRegular fid) -> ( - cassert (fid = ctx.fun_decl.def_id) ctx.fun_decl.meta "TODO: error message"; + sanity_check (fid = ctx.fun_decl.def_id) ctx.fun_decl.meta; (* Lookup the loop *) let lid = V.LoopId.Map.find lid ctx.loop_ids_map in let loop_info = LoopId.Map.find lid ctx.loops in @@ -1188,7 +1188,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) else false in let info = { fwd_info; effect_info = fwd_effect_info; ignore_output } in - cassert (fun_sig_info_is_wf info) meta "TODO: error message"; + sanity_check (fun_sig_info_is_wf info) meta; info in @@ -1541,7 +1541,7 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) match v.ty with | TAdt (TTuple, _) -> - cassert (variant_id = None) ctx.fun_decl.meta "TODO: error message"; + sanity_check (variant_id = None) ctx.fun_decl.meta; mk_simpl_tuple_texpression ctx.fun_decl.meta field_values | _ -> (* Retrieve the type and the translated generics from the translated @@ -1619,7 +1619,7 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert (field_values = []) ctx.fun_decl.meta "Only tuples can currently contain borrows"; + cassert (field_values = []) ctx.fun_decl.meta "ADTs containing borrows are not supported yet"; None | TTuple -> (* Return *) @@ -1687,7 +1687,7 @@ and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = (* The symbolic value was left unchanged *) Some (symbolic_value_to_texpression ctx msv) | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> - cassert (child_aproj = AIgnoredProjBorrows) ctx.fun_decl.meta "TODO: error message"; + sanity_check (child_aproj = AIgnoredProjBorrows) ctx.fun_decl.meta; (* The symbolic value was updated *) Some (symbolic_value_to_texpression ctx mnv) | V.AEndedProjLoans (_, _) -> @@ -1762,12 +1762,12 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert (field_values = []) ctx.fun_decl.meta "Only tuples can currently contain borrows"; + cassert (field_values = []) ctx.fun_decl.meta "ADTs with borrows are not supported yet"; (ctx, None) | TTuple -> (* Return *) let variant_id = adt_v.variant_id in - cassert (variant_id = None) ctx.fun_decl.meta "TODO: error message"; + sanity_check (variant_id = None) ctx.fun_decl.meta; if field_values = [] then (ctx, None) else (* Note that if there is exactly one field value, [mk_simpl_tuple_pattern] @@ -2042,9 +2042,9 @@ and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) (ctx : bs_ctx) : texpression = - cassert (is_continue = ctx.inside_loop) ctx.fun_decl.meta "TODO: error message"; + sanity_check (is_continue = ctx.inside_loop) ctx.fun_decl.meta; let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - cassert (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta "TODO: error message"; + sanity_check (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta; (* Lookup the loop information *) let loop_id = Option.get ctx.loop_id in @@ -2313,7 +2313,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : (match binop with (* The Rust compiler accepts bitshifts for any integer type combination for ty0, ty1 *) | E.Shl | E.Shr -> () - | _ -> cassert (int_ty0 = int_ty1) ctx.fun_decl.meta "TODO: error message"); + | _ -> sanity_check (int_ty0 = int_ty1) ctx.fun_decl.meta); let effect_info = { can_fail = ExpressionsUtils.binop_can_fail binop; @@ -2368,7 +2368,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) ^ T.RegionGroupId.to_string rg_id ^ "\n- loop_id: " ^ Print.option_to_string Pure.LoopId.to_string ctx.loop_id - ^ "\n- eval_ctx:\n" ^ eval_ctx_to_string ctx.fun_decl.meta ectx ^ "\n- abs:\n" + ^ "\n- eval_ctx:\n" ^ eval_ctx_to_string ~meta:(Some ctx.fun_decl.meta) ectx ^ "\n- abs:\n" ^ abs_to_string ctx abs ^ "\n")); (* When we end an input abstraction, this input abstraction gets back @@ -2382,7 +2382,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) for a parent backward function. *) let bid = Option.get ctx.bid in - cassert (rg_id = bid) ctx.fun_decl.meta "TODO: error message"; + sanity_check (rg_id = bid) ctx.fun_decl.meta; (* First, introduce the given back variables. @@ -2523,8 +2523,8 @@ and translate_end_abstraction_identity (ectx : C.eval_ctx) (abs : V.abs) (* We can do this simply by checking that it consumes and gives back nothing *) let inputs = abs_to_consumed ctx ectx abs in let ctx, outputs = abs_to_given_back None abs ctx in - cassert (inputs = []) ctx.fun_decl.meta "TODO: error message"; - cassert (outputs = []) ctx.fun_decl.meta "TODO: error message"; + sanity_check (inputs = []) ctx.fun_decl.meta; + sanity_check (outputs = []) ctx.fun_decl.meta; (* Translate the next expression *) translate_expression e ctx @@ -2566,7 +2566,7 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) (* Retrieve the values consumed upon ending the loans inside this * abstraction: as there are no nested borrows, there should be none. *) let consumed = abs_to_consumed ctx ectx abs in - cassert (consumed = []) ctx.fun_decl.meta "Nested borrows are not supported yet TODO: error message"; + cassert (consumed = []) ctx.fun_decl.meta "Nested borrows are not supported yet"; (* Retrieve the values given back upon ending this abstraction - note that * we don't provide meta-place information, because those assignments will * be inlined anyway... *) @@ -2601,7 +2601,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) texpression = let vloop_id = loop_id in let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - cassert (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta "TODO: error message"; + sanity_check (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta; let rg_id = Option.get rg_id in (* There are two cases depending on the [abs_kind] (whether this is a synth input or a regular loop call) *) @@ -2819,7 +2819,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) ^ pure_ty_to_string ctx true_e.ty ^ "\n\nfalse_e.ty: " ^ pure_ty_to_string ctx false_e.ty)); - if !Config.fail_hard then cassert (ty = false_e.ty) ctx.fun_decl.meta "TODO: error message"; (* TODO: remove if ? *) + save_error ~b:(ty = false_e.ty) (Some ctx.fun_decl.meta) "Internal error, please file an issue"; { e; ty } | ExpandInt (int_ty, branches, otherwise) -> let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : @@ -2844,8 +2844,8 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) Match all_branches ) in let ty = otherwise.branch.ty in - cassert ( - List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) ctx.fun_decl.meta "TODO: error message"; + sanity_check ( + List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) ctx.fun_decl.meta; { e; ty } (* Translate and [ExpandAdt] when there is no branching (i.e., one branch). @@ -3480,7 +3480,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* Add the loop information in the context *) let ctx = - cassert (not (LoopId.Map.mem loop_id ctx.loops)) ctx.fun_decl.meta "The loop information should not already be in the context TODO: error message"; + sanity_check (not (LoopId.Map.mem loop_id ctx.loops)) ctx.fun_decl.meta; (* Note that we will retrieve the input values later in the [ForwardEnd] (and will introduce the outputs at that moment, together with the actual diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 787bfb4f..bdd27d0f 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -47,7 +47,7 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (plac let get_scalar (see : symbolic_expansion option) : scalar_value = match see with | Some (SeLiteral (VScalar cv)) -> - cassert (cv.int_ty = int_ty) meta "For all the regular branches, the symbolic value should have been expanded to a constant TODO: Error message"; + sanity_check (cv.int_ty = int_ty) meta; cv | _ -> craise meta "Unreachable" in @@ -57,7 +57,7 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (plac (* For the otherwise branch, the symbolic value should have been left * unchanged *) let otherwise_see, otherwise = otherwise in - cassert (otherwise_see = None) meta "For the otherwise branch, the symbolic value should have been left unchanged"; + sanity_check (otherwise_see = None) meta; (* Return *) ExpandInt (int_ty, branches, otherwise) | TAdt (_, _) -> diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 11b179db..f97d7ab1 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -354,7 +354,7 @@ let export_type (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) *) let export_types_group (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (is_rec : bool) (ids : Pure.TypeDeclId.id list) : unit = - assert (ids <> []) (* meta "TODO: Error message" *); + assert (ids <> []); let export_type = export_type fmt config ctx in let ids_set = Pure.TypeDeclId.Set.of_list ids in let export_type_decl kind id = export_type ids_set kind id true false in @@ -396,11 +396,11 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) if List.exists (fun b -> b) builtin then (* Sanity check *) - assert (List.for_all (fun b -> b) builtin) (* meta "TODO: Error message" *) + assert (List.for_all (fun b -> b) builtin) else if List.exists dont_extract defs then (* Check if we have to ignore declarations *) (* Sanity check *) - assert (List.for_all dont_extract defs) (* meta "TODO: Error message" *) + assert (List.for_all dont_extract defs) else ( (* Extract the type declarations. @@ -447,8 +447,8 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) let global_decls = ctx.trans_ctx.global_ctx.global_decls in let global = GlobalDeclId.Map.find id global_decls in let trans = FunDeclId.Map.find global.body ctx.trans_funs in - cassert (trans.fwd.loops = []) global.meta "TODO: Error message"; - cassert (trans.backs = []) global.meta "TODO: Error message"; + sanity_check (trans.fwd.loops = []) global.meta; + sanity_check (trans.backs = []) global.meta; let body = trans.fwd.f in let is_opaque = Option.is_none body.Pure.body in @@ -915,7 +915,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : (* Initialize the names map by registering the keywords used in the language, as well as some primitive names ("u32", etc.). We insert the names of the local declarations later. *) - let names_maps = Extract.initialize_names_maps () in (*TODO*) + let names_maps = Extract.initialize_names_maps () in (* We need to compute which functions are recursive, in order to know * whether we should generate a decrease clause or not. *) @@ -1038,7 +1038,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : match Filename.chop_suffix_opt ~suffix:".llbc" filename with | None -> (* Note that we already checked the suffix upon opening the file *) - raise (Failure "Unreachable") (* TODO check *) + raise (Failure "Unreachable") | Some filename -> (* Retrieve the file basename *) let basename = Filename.basename filename in diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 51c9e8cc..9c4b8b45 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -12,23 +12,23 @@ let mk_unit_value : typed_value = { value = VAdt { variant_id = None; field_values = [] }; ty = mk_unit_ty } let mk_typed_value (meta : Meta.meta) (ty : ty) (value : value) : typed_value = - cassert (ty_is_ety ty) meta "TODO: error message"; + sanity_check (ty_is_ety ty) meta; { value; ty } let mk_typed_avalue (meta : Meta.meta) (ty : ty) (value : avalue) : typed_avalue = - cassert (ty_is_rty ty) meta "TODO: error message"; + sanity_check (ty_is_rty ty) meta; { value; ty } let mk_bottom (meta : Meta.meta) (ty : ty) : typed_value = - cassert (ty_is_ety ty) meta "TODO: error message"; + sanity_check (ty_is_ety ty) meta; { value = VBottom; ty } let mk_abottom (meta : Meta.meta) (ty : ty) : typed_avalue = - cassert (ty_is_rty ty) meta "TODO: error message"; + sanity_check (ty_is_rty ty) meta; { value = ABottom; ty } let mk_aignored (meta : Meta.meta) (ty : ty) : typed_avalue = - cassert (ty_is_rty ty) meta "TODO: error message"; + sanity_check (ty_is_rty ty) meta; { value = AIgnored; ty } let value_as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = -- cgit v1.2.3 From 53347ecc40b308b0b75a620453bfa8bd520a2c70 Mon Sep 17 00:00:00 2001 From: Escherichia Date: Thu, 28 Mar 2024 16:31:24 +0100 Subject: changes after git rebase main --- compiler/Extract.ml | 14 ++++++++------ compiler/ExtractBase.ml | 24 ++++++++++++++++-------- compiler/ExtractTypes.ml | 2 +- compiler/InterpreterLoops.ml | 4 ++-- compiler/InterpreterLoopsFixedPoint.ml | 14 +++++++------- compiler/InterpreterLoopsFixedPoint.mli | 2 +- compiler/InterpreterLoopsMatchCtxs.ml | 8 ++++---- compiler/InterpreterLoopsMatchCtxs.mli | 2 +- compiler/PureMicroPasses.ml | 2 +- compiler/SymbolicToPure.ml | 14 +++++++------- compiler/Translate.ml | 5 ++--- 11 files changed, 50 insertions(+), 41 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 0e86e187..43acba94 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -46,7 +46,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) let f = def.f in let open ExtractBuiltin in let fun_id = (Pure.FunId (FRegular f.def_id), f.loop_id) in - ctx_add (FunId (FromLlbc fun_id)) fun_info.extract_name ctx + ctx_add f.meta (FunId (FromLlbc fun_id)) fun_info.extract_name ctx | None -> (* Not builtin *) (* If this is a trait method implementation, we prefix the name with the @@ -194,7 +194,7 @@ let extract_global (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (* Extract the global name *) F.pp_print_string fmt (ctx_get_global meta id ctx); (* Extract the generics *) - extract_generic_args ctx fmt TypeDeclId.Set.empty generics; + extract_generic_args meta ctx fmt TypeDeclId.Set.empty generics; if use_brackets then F.pp_print_string fmt ")"; F.pp_close_box fmt () @@ -336,7 +336,7 @@ and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (i | AdtCons adt_cons_id -> extract_adt_cons meta ctx fmt inside adt_cons_id qualif.generics args | Proj proj -> - extract_field_projector ctx fmt inside app proj qualif.generics args + extract_field_projector meta ctx fmt inside app proj qualif.generics args | TraitConst (trait_ref, const_name) -> extract_trait_ref meta ctx fmt TypeDeclId.Set.empty true trait_ref; let name = @@ -1735,7 +1735,7 @@ let extract_global_decl_body_gen (meta : Meta.meta) (ctx : extraction_ctx) (fmt (* Extract the generic parameters *) let space = ref true in - extract_generic_params ctx fmt TypeDeclId.Set.empty ~space:(Some space) + extract_generic_params meta ctx fmt TypeDeclId.Set.empty ~space:(Some space) generics type_params cg_params trait_clauses; if not !space then F.pp_print_space fmt (); @@ -1838,6 +1838,8 @@ let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) (f *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : global_decl) (body : fun_decl) (interface : bool) : unit = + + let meta = body.meta in cassert body.is_global_decl_body body.meta "TODO: Error message"; cassert (body.signature.inputs = []) body.meta "TODO: Error message"; @@ -1865,7 +1867,7 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) in (* Add the type parameters *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params global.llbc_name global.llbc_generics global.generics + ctx_add_generic_params meta global.llbc_name global.llbc_generics global.generics ctx in match body.body with @@ -2657,7 +2659,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) is a provided constant or not *) let print_params () = if provided_id = Some id then - extract_generic_args ctx fmt TypeDeclId.Set.empty + extract_generic_args impl.meta ctx fmt TypeDeclId.Set.empty impl.impl_trait.decl_generics else let all_params = diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 022643f5..aae11f19 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1273,12 +1273,20 @@ let ctx_prepare_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name craise meta ("Unexpected name shape: " - ^ TranslateCore.name_to_string ctx.trans_ctx name)) + ^ TranslateCore.name_to_string ctx.trans_ctx name) + +(** Helper *) +let ctx_compute_simple_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : + string list = + (* Rmk.: initially we only filtered the disambiguators equal to 0 *) + let name = ctx_prepare_name meta ctx name in + name_to_simple_name ctx.trans_ctx name (** Helper *) let ctx_compute_simple_type_name = ctx_compute_simple_name (** Helper *) + let ctx_compute_type_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : string = flatten_name (ctx_compute_simple_type_name meta ctx name) @@ -1369,7 +1377,7 @@ let ctx_compute_global_name (meta : Meta.meta) (ctx : extraction_ctx) (name : ll | Coq | FStar | HOL4 -> let parts = List.map to_snake_case (ctx_compute_simple_name meta ctx name) in String.concat "_" parts - | Lean -> flatten_name (ctx_compute_simple_name ctx name) + | Lean -> flatten_name (ctx_compute_simple_name meta ctx name) (** Helper function: generate a suffix for a function name, i.e., generates a suffix like "_loop", "loop1", etc. to append to a function name. @@ -1386,7 +1394,7 @@ let default_fun_loop_suffix (num_loops : int) (loop_id : LoopId.id option) : (** A helper function: generates a function suffix. TODO: move all those helpers. *) -let default_fun_suffix (meta : Meta.meta) (num_loops : int) (loop_id : LoopId.id option) : string = +let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) : string = (* We only generate a suffix for the functions we generate from the loops *) default_fun_loop_suffix num_loops loop_id @@ -1404,7 +1412,7 @@ let ctx_compute_fun_name (meta : Meta.meta) (ctx : extraction_ctx) (fname : llbc (num_loops : int) (loop_id : LoopId.id option) : string = let fname = ctx_compute_fun_name_no_suffix meta ctx fname in (* Compute the suffix *) - let suffix = default_fun_suffix meta num_loops loop_id in + let suffix = default_fun_suffix num_loops loop_id in (* Concatenate *) fname ^ suffix @@ -1423,7 +1431,7 @@ let ctx_compute_trait_impl_name (ctx : extraction_ctx) (trait_decl : trait_decl) let name = let params = trait_impl.llbc_generics in let args = trait_impl.llbc_impl_trait.decl_generics in - let name = ctx_prepare_name ctx trait_decl.llbc_name in + let name = ctx_prepare_name trait_impl.meta ctx trait_decl.llbc_name in trait_name_with_generics_to_simple_name ctx.trans_ctx name params args in let name = flatten_name name in @@ -1879,7 +1887,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : ctx_add def.meta decl name ctx | None -> (* Not the case: "standard" registration *) - let name = ctx_compute_global_name ctx def.name in + let name = ctx_compute_global_name def.meta ctx def.name in let body = FunId (FromLlbc (FunId (FRegular def.body), None)) in (* If this is a provided constant (i.e., the default value for a constant in a trait declaration) we add a suffix. Otherwise there is a clash @@ -1888,8 +1896,8 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : let suffix = match def.kind with TraitItemProvided _ -> "_default" | _ -> "" in - let ctx = ctx_add decl (name ^ suffix) ctx in - let ctx = ctx_add body (name ^ suffix ^ "_body") ctx in + let ctx = ctx_add def.meta decl (name ^ suffix) ctx in + let ctx = ctx_add def.meta body (name ^ suffix ^ "_body") ctx in ctx let ctx_compute_fun_name (def : fun_decl) (ctx : extraction_ctx) : string = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index a8143876..94acd08c 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -548,7 +548,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) *) match trait_ref.trait_id with | Self -> - cassert (trait_ref.generics = empty_generic_args) "TODO: Error message"; + cassert (trait_ref.generics = empty_generic_args) meta "TODO: Error message"; extract_trait_instance_id_with_dot meta ctx fmt no_params_tys false trait_ref.trait_id; F.pp_print_string fmt type_name diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index d2f1b5fb..89015f71 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -102,7 +102,7 @@ let eval_loop_symbolic (config : config) (meta : meta) - src ctx (fixed-point ctx):\n" ^ eval_ctx_to_string fp_ctx ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string ctx)); - prepare_match_ctx_with_target config loop_id fixed_ids fp_ctx cf ctx + prepare_match_ctx_with_target config meta loop_id fixed_ids fp_ctx cf ctx in (* Actually match *) @@ -264,7 +264,7 @@ let eval_loop (config : config) (meta : meta) (eval_loop_body : st_cm_fun) : | SymbolicMode -> (* Simplify the context by ending the unnecessary borrows/loans and getting rid of the useless symbolic values (which are in anonymous variables) *) - let cc = cleanup_fresh_values_and_abs config empty_ids_set in + let cc = cleanup_fresh_values_and_abs config meta empty_ids_set in (* We want to make sure the loop will *not* manipulate shared avalues containing themselves shared loans (i.e., nested shared loans in diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index f6ce9b32..f5bd4a35 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -23,7 +23,7 @@ exception FoundAbsId of AbstractionId.id - end the borrows which appear in fresh anonymous values and don't contain loans - end the fresh region abstractions which can be ended (no loans) *) -let rec end_useless_fresh_borrows_and_abs (config : config) +let rec end_useless_fresh_borrows_and_abs (config : config) (meta : Meta.meta) (fixed_ids : ids_sets) : cm_fun = fun cf ctx -> let rec explore_env (env : env) : unit = @@ -56,7 +56,7 @@ let rec end_useless_fresh_borrows_and_abs (config : config) | EAbs abs :: env when not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids) -> ( (* Check if it is possible to end the abstraction: if yes, raise an exception *) - let opt_loan = get_first_non_ignored_aloan_in_abstraction abs in + let opt_loan = get_first_non_ignored_aloan_in_abstraction meta abs in match opt_loan with | None -> (* No remaining loans: we can end the abstraction *) @@ -66,7 +66,7 @@ let rec end_useless_fresh_borrows_and_abs (config : config) explore_env env) | _ :: env -> explore_env env in - let rec_call = end_useless_fresh_borrows_and_abs config fixed_ids in + let rec_call = end_useless_fresh_borrows_and_abs config meta fixed_ids in try (* Explore the environment *) explore_env ctx.env; @@ -74,10 +74,10 @@ let rec end_useless_fresh_borrows_and_abs (config : config) cf ctx with | FoundAbsId abs_id -> - let cc = end_abstraction config abs_id in + let cc = end_abstraction config meta abs_id in comp cc rec_call cf ctx | FoundBorrowId bid -> - let cc = end_borrow config bid in + let cc = end_borrow config meta bid in comp cc rec_call cf ctx (* Explore the fresh anonymous values and replace all the values which are not @@ -121,11 +121,11 @@ let cleanup_fresh_values (fixed_ids : ids_sets) : cm_fun = - also end the borrows which appear in fresh anonymous values and don't contain loans - end the fresh region abstractions which can be ended (no loans) *) -let cleanup_fresh_values_and_abs (config : config) (fixed_ids : ids_sets) : +let cleanup_fresh_values_and_abs (config : config) (meta : Meta.meta) (fixed_ids : ids_sets) : cm_fun = fun cf ctx -> comp - (end_useless_fresh_borrows_and_abs config fixed_ids) + (end_useless_fresh_borrows_and_abs config meta fixed_ids) (cleanup_fresh_values fixed_ids) cf ctx diff --git a/compiler/InterpreterLoopsFixedPoint.mli b/compiler/InterpreterLoopsFixedPoint.mli index 4568bf79..54e4d780 100644 --- a/compiler/InterpreterLoopsFixedPoint.mli +++ b/compiler/InterpreterLoopsFixedPoint.mli @@ -13,7 +13,7 @@ open InterpreterLoopsCore - config - fixed ids (the fixeds ids are the ids we consider as non-fresh) *) -val cleanup_fresh_values_and_abs : config -> ids_sets -> Cps.cm_fun +val cleanup_fresh_values_and_abs : config -> Meta.meta -> ids_sets -> Cps.cm_fun (** Prepare the shared loans in the abstractions by moving them to fresh abstractions. diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index c02d3117..24e588f2 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -459,8 +459,8 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Lookup the shared values and match them - we do this mostly to make sure we end loans which might appear on one side and not on the other. *) - let sv0 = lookup_shared_value ctx0 bid0 in - let sv1 = lookup_shared_value ctx1 bid1 in + let sv0 = lookup_shared_value meta ctx0 bid0 in + let sv1 = lookup_shared_value meta ctx1 bid1 in let sv = match_rec sv0 sv1 in if bid0 = bid1 then bid0 else @@ -1544,7 +1544,7 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (* Apply the reorganization *) cf_reorganize_join_tgt cf tgt_ctx -let match_ctx_with_target (config : config) (loop_id : LoopId.id) +let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId.id) (is_loop_entry : bool) (fp_bl_maps : borrow_loan_corresp) (fp_input_svalues : SymbolicValueId.id list) (fixed_ids : ids_sets) (src_ctx : eval_ctx) : st_cm_fun = @@ -1562,7 +1562,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) were introduced during the loop iterations) *) let cf_reorganize_join_tgt = - prepare_match_ctx_with_target config loop_id fixed_ids src_ctx + prepare_match_ctx_with_target config meta loop_id fixed_ids src_ctx in (* Introduce the "identity" abstractions for the loop re-entry. diff --git a/compiler/InterpreterLoopsMatchCtxs.mli b/compiler/InterpreterLoopsMatchCtxs.mli index 4a6d24a9..a8002ad4 100644 --- a/compiler/InterpreterLoopsMatchCtxs.mli +++ b/compiler/InterpreterLoopsMatchCtxs.mli @@ -151,7 +151,7 @@ val ctxs_are_equivalent : Meta.meta -> ids_sets -> eval_ctx -> eval_ctx -> bool *) val prepare_match_ctx_with_target : - config -> LoopId.id -> ids_sets -> eval_ctx -> cm_fun + config -> Meta.meta -> LoopId.id -> ids_sets -> eval_ctx -> cm_fun (** Match a context with a target context. diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 1df7176d..ab4686c9 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1140,7 +1140,7 @@ let simplify_let_then_return _ctx (def : fun_decl) = (* The first let-binding is monadic *) match opt_destruct_ret next_e with | Some e -> - if match_pattern_and_expr def.meta lv e then rv.e else not_simpl_e + if match_pattern_and_expr lv e then rv.e else not_simpl_e | None -> not_simpl_e else (* The first let-binding is not monadic *) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index e60d6870..3532b2dd 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -1325,7 +1325,7 @@ let compute_output_ty_from_decomposed (dsg : Pure.decomposed_fun_sig) : ty = in mk_output_ty_from_effect_info effect_info output -let translate_fun_sig_from_decomposed (meta : Meta.meta) (dsg : Pure.decomposed_fun_sig) : fun_sig +let translate_fun_sig_from_decomposed (dsg : Pure.decomposed_fun_sig) : fun_sig = let generics = dsg.generics in let llbc_generics = dsg.llbc_generics in @@ -2512,7 +2512,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) ^ "\nfunc type: " ^ pure_ty_to_string ctx func.ty ^ "\n\nargs:\n" ^ String.concat "\n" args)); - let call = mk_apps func args in + let call = mk_apps ctx.fun_decl.meta func args in mk_let effect_info.can_fail output call next_e and translate_end_abstraction_identity (ectx : C.eval_ctx) (abs : V.abs) @@ -2671,7 +2671,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) match func with | None -> next_e | Some func -> - let call = mk_apps func args in + let call = mk_apps ctx.fun_decl.meta func args in (* Add meta-information - this is slightly hacky: we look at the values consumed by the abstraction (note that those come from *before* we applied the fixed-point context) and use them to @@ -3682,7 +3682,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = let llbc_name = def.name in let name = name_to_string ctx llbc_name in (* Translate the signature *) - let signature = translate_fun_sig_from_decomposed def.meta ctx.sg in + let signature = translate_fun_sig_from_decomposed ctx.sg in (* Translate the body, if there is *) let body = match body with @@ -3915,9 +3915,9 @@ let translate_global (ctx : Contexts.decls_ctx) (decl : A.global_decl) : (Print.Contexts.decls_ctx_to_fmt_env ctx) llbc_name in - let generics = translate_generic_params llbc_generics in - let preds = translate_predicates preds in - let ty = translate_fwd_ty ctx.type_ctx.type_infos ty in + let generics = translate_generic_params decl.meta llbc_generics in + let preds = translate_predicates decl.meta preds in + let ty = translate_fwd_ty decl.meta ctx.type_ctx.type_infos ty in { meta; def_id; diff --git a/compiler/Translate.ml b/compiler/Translate.ml index f97d7ab1..9834fe81 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -447,9 +447,8 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) let global_decls = ctx.trans_ctx.global_ctx.global_decls in let global = GlobalDeclId.Map.find id global_decls in let trans = FunDeclId.Map.find global.body ctx.trans_funs in - sanity_check (trans.fwd.loops = []) global.meta; - sanity_check (trans.backs = []) global.meta; - let body = trans.fwd.f in + sanity_check (trans.loops = []) global.meta; + let body = trans.f in let is_opaque = Option.is_none body.Pure.body in (* Check if we extract the global *) -- cgit v1.2.3 From 64666edb3c10cd42e15937ac4038b83def630e35 Mon Sep 17 00:00:00 2001 From: Escherichia Date: Thu, 28 Mar 2024 17:14:27 +0100 Subject: formatting --- compiler/AssociatedTypes.ml | 57 ++++-- compiler/Contexts.ml | 75 +++++--- compiler/Errors.ml | 59 +++--- compiler/Extract.ml | 296 ++++++++++++++++++----------- compiler/ExtractBase.ml | 237 +++++++++++++----------- compiler/ExtractName.ml | 3 +- compiler/ExtractTypes.ml | 167 ++++++++++------- compiler/FunsAnalysis.ml | 11 +- compiler/Interpreter.ml | 43 +++-- compiler/InterpreterBorrows.ml | 317 +++++++++++++++++++------------- compiler/InterpreterBorrows.mli | 14 +- compiler/InterpreterBorrowsCore.ml | 118 ++++++------ compiler/InterpreterExpansion.ml | 180 +++++++++--------- compiler/InterpreterExpansion.mli | 19 +- compiler/InterpreterExpressions.ml | 174 +++++++++++------- compiler/InterpreterExpressions.mli | 20 +- compiler/InterpreterLoops.ml | 34 ++-- compiler/InterpreterLoopsCore.ml | 6 +- compiler/InterpreterLoopsFixedPoint.ml | 74 +++++--- compiler/InterpreterLoopsFixedPoint.mli | 7 +- compiler/InterpreterLoopsJoinCtxs.ml | 93 ++++++---- compiler/InterpreterLoopsJoinCtxs.mli | 3 +- compiler/InterpreterLoopsMatchCtxs.ml | 203 +++++++++++--------- compiler/InterpreterPaths.ml | 93 +++++----- compiler/InterpreterPaths.mli | 12 +- compiler/InterpreterProjectors.ml | 109 +++++------ compiler/InterpreterProjectors.mli | 14 +- compiler/InterpreterStatements.ml | 221 +++++++++++++--------- compiler/InterpreterStatements.mli | 3 +- compiler/InterpreterUtils.ml | 41 +++-- compiler/Invariants.ml | 124 ++++++++----- compiler/Main.ml | 4 +- compiler/PrePasses.ml | 14 +- compiler/Print.ml | 167 +++++++++-------- compiler/PrintPure.ml | 141 ++++++++------ compiler/PureMicroPasses.ml | 23 ++- compiler/PureTypeCheck.ml | 27 +-- compiler/PureUtils.ml | 36 ++-- compiler/RegionsHierarchy.ml | 22 ++- compiler/Substitute.ml | 22 ++- compiler/SymbolicToPure.ml | 275 +++++++++++++++++---------- compiler/SynthesizeSymbolic.ml | 26 +-- compiler/ValuesUtils.ml | 6 +- 43 files changed, 2155 insertions(+), 1435 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index a4b0e921..5d5f53a4 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -83,7 +83,7 @@ let compute_norm_trait_types_from_preds (meta : Meta.meta option) let ctx_add_norm_trait_types_from_preds (meta : Meta.meta) (ctx : eval_ctx) (trait_type_constraints : trait_type_constraint list) : eval_ctx = let norm_trait_types = - compute_norm_trait_types_from_preds (Some meta) trait_type_constraints + compute_norm_trait_types_from_preds (Some meta) trait_type_constraints in { ctx with norm_trait_types } @@ -239,7 +239,9 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = match trait_ref.trait_id with | TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ } -> - cassert_opt_meta (ref_generics = empty_generic_args) ctx.meta "Higher order trait types are not supported yet"; + cassert_opt_meta + (ref_generics = empty_generic_args) + ctx.meta "Higher order trait types are not supported yet"; log#ldebug (lazy ("norm_ctx_normalize_ty: trait type: trait ref: " @@ -279,7 +281,9 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* We can't project *) - sanity_check_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta ; + sanity_check_opt_meta + (trait_instance_id_is_local_clause trait_ref.trait_id) + ctx.meta; TTraitType (trait_ref, type_name) in let tr : trait_type_ref = { trait_ref; type_name } in @@ -347,7 +351,9 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) match impl with | None -> (* This is actually a local clause *) - sanity_check_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta ; + sanity_check_opt_meta + (trait_instance_id_is_local_clause inst_id) + ctx.meta; (ParentClause (inst_id, decl_id, clause_id), None) | Some impl -> (* We figure out the parent clause by doing the following: @@ -378,7 +384,9 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) match impl with | None -> (* This is actually a local clause *) - sanity_check_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta ; + sanity_check_opt_meta + (trait_instance_id_is_local_clause inst_id) + ctx.meta; (ItemClause (inst_id, decl_id, item_name, clause_id), None) | Some impl -> (* We figure out the item clause by doing the following: @@ -418,8 +426,12 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) - cassert_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta "Trait instance id is not a local sub-clause"; - cassert_opt_meta (trait_ref.generics = empty_generic_args) ctx.meta "TODO: error message"; + cassert_opt_meta + (trait_instance_id_is_local_clause trait_ref.trait_id) + ctx.meta "Trait instance id is not a local sub-clause"; + cassert_opt_meta + (trait_ref.generics = empty_generic_args) + ctx.meta "TODO: error message"; (trait_ref.trait_id, None) | FnPointer ty -> let ty = norm_ctx_normalize_ty ctx ty in @@ -468,7 +480,9 @@ and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : trait_ref) : (lazy ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); - cassert_opt_meta (generics = empty_generic_args) ctx.meta "TODO: error message"; + cassert_opt_meta + (generics = empty_generic_args) + ctx.meta "TODO: error message"; trait_ref (* Not sure this one is really necessary *) @@ -511,8 +525,8 @@ let ctx_normalize_trait_type_constraint (meta : Meta.meta) (ctx : eval_ctx) norm_ctx_normalize_trait_type_constraint (mk_norm_ctx meta ctx) ttc (** Same as [type_decl_get_instantiated_variants_fields_types] but normalizes the types *) -let type_decl_get_inst_norm_variants_fields_rtypes (meta : Meta.meta) (ctx : eval_ctx) - (def : type_decl) (generics : generic_args) : +let type_decl_get_inst_norm_variants_fields_rtypes (meta : Meta.meta) + (ctx : eval_ctx) (def : type_decl) (generics : generic_args) : (VariantId.id option * ty list) list = let res = Subst.type_decl_get_instantiated_variants_fields_types def generics @@ -523,16 +537,17 @@ let type_decl_get_inst_norm_variants_fields_rtypes (meta : Meta.meta) (ctx : eva res (** Same as [type_decl_get_instantiated_field_types] but normalizes the types *) -let type_decl_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (def : type_decl) - (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = +let type_decl_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) + (def : type_decl) (opt_variant_id : VariantId.id option) + (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in List.map (ctx_normalize_ty meta ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) -let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (adt : adt_value) - (id : type_id) (generics : generic_args) : ty list = +let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) + (adt : adt_value) (id : type_id) (generics : generic_args) : ty list = let types = Subst.ctx_adt_value_get_instantiated_field_types meta ctx adt id generics in @@ -540,8 +555,9 @@ let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (** Same as [ctx_adt_value_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let type_decl_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) (def : type_decl) - (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = +let type_decl_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) + (def : type_decl) (opt_variant_id : VariantId.id option) + (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in @@ -550,8 +566,9 @@ let type_decl_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) (de (** Same as [ctx_adt_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let ctx_adt_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) - (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = +let ctx_adt_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) + (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) + (generics : generic_args) : ty list = let types = Subst.ctx_adt_get_instantiated_field_types ctx def_id opt_variant_id generics @@ -575,6 +592,8 @@ let ctx_subst_norm_signature (meta : Meta.meta) (ctx : eval_ctx) let inputs = List.map (ctx_normalize_ty meta ctx) inputs in let output = ctx_normalize_ty meta ctx output in let trait_type_constraints = - List.map (ctx_normalize_trait_type_constraint meta ctx) trait_type_constraints + List.map + (ctx_normalize_trait_type_constraint meta ctx) + trait_type_constraints in { regions_hierarchy; inputs; output; trait_type_constraints } diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 51392edf..c2d6999a 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -286,7 +286,8 @@ let lookup_const_generic_var (ctx : eval_ctx) (vid : ConstGenericVarId.id) : ConstGenericVarId.nth ctx.const_generic_vars vid (** Lookup a variable in the current frame *) -let env_lookup_var (meta : Meta.meta) (env : env) (vid : VarId.id) : var_binder * typed_value = +let env_lookup_var (meta : Meta.meta) (env : env) (vid : VarId.id) : + var_binder * typed_value = (* We take care to stop at the end of current frame: different variables in different frames can have the same id! *) @@ -301,7 +302,8 @@ let env_lookup_var (meta : Meta.meta) (env : env) (vid : VarId.id) : var_binder in lookup env -let ctx_lookup_var_binder (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : var_binder = +let ctx_lookup_var_binder (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : + var_binder = fst (env_lookup_var meta ctx.env vid) let ctx_lookup_type_decl (ctx : eval_ctx) (tid : TypeDeclId.id) : type_decl = @@ -321,11 +323,13 @@ let ctx_lookup_trait_impl (ctx : eval_ctx) (id : TraitImplId.id) : trait_impl = TraitImplId.Map.find id ctx.trait_impls_ctx.trait_impls (** Retrieve a variable's value in the current frame *) -let env_lookup_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) : typed_value = +let env_lookup_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) : + typed_value = snd (env_lookup_var meta env vid) (** Retrieve a variable's value in an evaluation context *) -let ctx_lookup_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : typed_value = +let ctx_lookup_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : + typed_value = env_lookup_var_value meta ctx.env vid (** Retrieve a const generic value in an evaluation context *) @@ -338,7 +342,8 @@ let ctx_lookup_const_generic_value (ctx : eval_ctx) (vid : ConstGenericVarId.id) This is a helper function: it can break invariants and doesn't perform any check. *) -let env_update_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) (nv : typed_value) : env = +let env_update_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) + (nv : typed_value) : env = (* We take care to stop at the end of current frame: different variables in different frames can have the same id! *) @@ -361,8 +366,8 @@ let var_to_binder (var : var) : var_binder = This is a helper function: it can break invariants and doesn't perform any check. *) -let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : - eval_ctx = +let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) + (nv : typed_value) : eval_ctx = { ctx with env = env_update_var_value meta ctx.env vid nv } (** Push a variable in the context's environment. @@ -370,8 +375,11 @@ let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) (n Checks that the pushed variable and its value have the same type (this is important). *) -let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - cassert (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty) meta "The pushed variables and their values do not have the same type"; +let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) + (v : typed_value) : eval_ctx = + cassert + (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty) + meta "The pushed variables and their values do not have the same type"; let bv = var_to_binder var in { ctx with env = EBinding (BVar bv, v) :: ctx.env } @@ -380,8 +388,8 @@ let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) (v : typed_valu Checks that the pushed variables and their values have the same type (this is important). *) -let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx - = +let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) + (vars : (var * typed_value) list) : eval_ctx = log#ldebug (lazy ("push_vars:\n" @@ -391,11 +399,14 @@ let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : (var * typed_value (* We can unfortunately not use Print because it depends on Contexts... *) show_var var ^ " -> " ^ show_typed_value value) vars))); - cassert ( - List.for_all - (fun (var, (value : typed_value)) -> - TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) - vars) meta "The pushed variables and their values do not have the same type TODO: Error message"; + cassert + (List.for_all + (fun (var, (value : typed_value)) -> + TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) + vars) + meta + "The pushed variables and their values do not have the same type TODO: \ + Error message"; let vars = List.map (fun (var, value) -> EBinding (BVar (var_to_binder var), value)) @@ -431,7 +442,8 @@ let ctx_remove_dummy_var meta (ctx : eval_ctx) (vid : DummyVarId.id) : ({ ctx with env }, v) (** Lookup a dummy variable in a context's environment. *) -let ctx_lookup_dummy_var (meta : Meta.meta) (ctx : eval_ctx) (vid : DummyVarId.id) : typed_value = +let ctx_lookup_dummy_var (meta : Meta.meta) (ctx : eval_ctx) + (vid : DummyVarId.id) : typed_value = let rec lookup_var (env : env) : typed_value = match env with | [] -> craise meta "Could not lookup a dummy variable" @@ -450,12 +462,16 @@ let erase_regions (ty : ty) : ty = v#visit_ty () ty (** Push an uninitialized variable (which thus maps to {!constructor:Values.value.VBottom}) *) -let ctx_push_uninitialized_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) : eval_ctx = +let ctx_push_uninitialized_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) : + eval_ctx = ctx_push_var meta ctx var (mk_bottom meta (erase_regions var.var_ty)) (** Push a list of uninitialized variables (which thus map to {!constructor:Values.value.VBottom}) *) -let ctx_push_uninitialized_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : var list) : eval_ctx = - let vars = List.map (fun v -> (v, mk_bottom meta (erase_regions v.var_ty))) vars in +let ctx_push_uninitialized_vars (meta : Meta.meta) (ctx : eval_ctx) + (vars : var list) : eval_ctx = + let vars = + List.map (fun v -> (v, mk_bottom meta (erase_regions v.var_ty))) vars + in ctx_push_vars meta ctx vars let env_find_abs (env : env) (pred : abs -> bool) : abs option = @@ -475,7 +491,8 @@ let env_lookup_abs_opt (env : env) (abs_id : AbstractionId.id) : abs option = this abstraction (for instance, remove the abs id from all the parent sets of all the other abstractions). *) -let env_remove_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) : env * abs option = +let env_remove_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) : + env * abs option = let rec remove (env : env) : env * abs option = match env with | [] -> craise meta "Unreachable" @@ -500,8 +517,8 @@ let env_remove_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) : we also substitute the abstraction id wherever it is used (i.e., in the parent sets of the other abstractions). *) -let env_subst_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) (nabs : abs) : - env * abs option = +let env_subst_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) + (nabs : abs) : env * abs option = let rec update (env : env) : env * abs option = match env with | [] -> craise meta "Unreachable" @@ -536,19 +553,19 @@ let ctx_find_abs (ctx : eval_ctx) (p : abs -> bool) : abs option = env_find_abs ctx.env p (** See the comments for {!env_remove_abs} *) -let ctx_remove_abs (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) : - eval_ctx * abs option = +let ctx_remove_abs (meta : Meta.meta) (ctx : eval_ctx) + (abs_id : AbstractionId.id) : eval_ctx * abs option = let env, abs = env_remove_abs meta ctx.env abs_id in ({ ctx with env }, abs) (** See the comments for {!env_subst_abs} *) -let ctx_subst_abs (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) (nabs : abs) : - eval_ctx * abs option = +let ctx_subst_abs (meta : Meta.meta) (ctx : eval_ctx) + (abs_id : AbstractionId.id) (nabs : abs) : eval_ctx * abs option = let env, abs_opt = env_subst_abs meta ctx.env abs_id nabs in ({ ctx with env }, abs_opt) -let ctx_set_abs_can_end (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) - (can_end : bool) : eval_ctx = +let ctx_set_abs_can_end (meta : Meta.meta) (ctx : eval_ctx) + (abs_id : AbstractionId.id) (can_end : bool) : eval_ctx = let abs = ctx_lookup_abs ctx abs_id in let abs = { abs with can_end } in fst (ctx_subst_abs meta ctx abs_id abs) diff --git a/compiler/Errors.ml b/compiler/Errors.ml index aff62022..3b34397a 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -1,10 +1,10 @@ -let meta_to_string (span : Meta.span ) = +let meta_to_string (span : Meta.span) = let file = match span.file with Virtual s | Local s -> s in let loc_to_string (l : Meta.loc) : string = string_of_int l.line ^ ":" ^ string_of_int l.col in - "Source: '" ^ file ^ "', lines " ^ loc_to_string span.beg_loc ^ "-" - ^ loc_to_string span.end_loc + "Source: '" ^ file ^ "', lines " ^ loc_to_string span.beg_loc ^ "-" + ^ loc_to_string span.end_loc let format_error_message (meta : Meta.meta) msg = msg ^ ":" ^ meta_to_string meta.span @@ -12,47 +12,44 @@ let format_error_message (meta : Meta.meta) msg = exception CFailure of string let error_list : (Meta.meta option * string) list ref = ref [] -let push_error (meta : Meta.meta option) (msg : string) = error_list := (meta, msg)::(!error_list) -let save_error ?(b : bool = true) (meta : Meta.meta option) (msg : string) = +let push_error (meta : Meta.meta option) (msg : string) = + error_list := (meta, msg) :: !error_list + +let save_error ?(b : bool = true) (meta : Meta.meta option) (msg : string) = push_error meta msg; - match meta with + match meta with | Some m -> - if !Config.fail_hard && b then - raise (Failure (format_error_message m msg)) - | None -> - if !Config.fail_hard && b then - raise (Failure msg) + if !Config.fail_hard && b then + raise (Failure (format_error_message m msg)) + | None -> if !Config.fail_hard && b then raise (Failure msg) let craise_opt_meta (meta : Meta.meta option) (msg : string) = - match meta with + match meta with | Some m -> - if !Config.fail_hard then - raise (Failure (format_error_message m msg)) - else - let () = push_error (Some m) msg in - raise (CFailure msg) - | None -> - if !Config.fail_hard then - raise (Failure msg) - else - let () = push_error None msg in - raise (CFailure msg) - -let craise (meta : Meta.meta) (msg : string) = - craise_opt_meta (Some meta) msg + if !Config.fail_hard then raise (Failure (format_error_message m msg)) + else + let () = push_error (Some m) msg in + raise (CFailure msg) + | None -> + if !Config.fail_hard then raise (Failure msg) + else + let () = push_error None msg in + raise (CFailure msg) + +let craise (meta : Meta.meta) (msg : string) = craise_opt_meta (Some meta) msg let cassert_opt_meta (b : bool) (meta : Meta.meta option) (msg : string) = - if b then - craise_opt_meta meta msg + if b then craise_opt_meta meta msg let cassert (b : bool) (meta : Meta.meta) (msg : string) = cassert_opt_meta b (Some meta) msg let sanity_check b meta = cassert b meta "Internal error, please file an issue" -let sanity_check_opt_meta b meta = cassert_opt_meta b meta "Internal error, please file an issue" -let internal_error meta = craise meta "Internal error, please report an issue" +let sanity_check_opt_meta b meta = + cassert_opt_meta b meta "Internal error, please file an issue" +let internal_error meta = craise meta "Internal error, please report an issue" let exec_raise = craise -let exec_assert = cassert \ No newline at end of file +let exec_assert = cassert diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 43acba94..72cd91e5 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -128,8 +128,12 @@ let extract_adt_g_value (meta : Meta.meta) | TAdt (TTuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) - cassert (List.length generics.types = List.length field_values) meta "Only fully applied tuple constructors are currently supported"; - cassert (generics.const_generics = [] && generics.trait_refs = []) meta "Only fully applied tuple constructors are currently supported"; + cassert + (List.length generics.types = List.length field_values) + meta "Only fully applied tuple constructors are currently supported"; + cassert + (generics.const_generics = [] && generics.trait_refs = []) + meta "Only fully applied tuple constructors are currently supported"; extract_as_tuple () | TAdt (adt_id, _) -> (* "Regular" ADT *) @@ -186,8 +190,8 @@ let extract_adt_g_value (meta : Meta.meta) | _ -> craise meta "Inconsistent typed value" (* Extract globals in the same way as variables *) -let extract_global (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (id : A.GlobalDeclId.id) (generics : generic_args) : unit = +let extract_global (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (id : A.GlobalDeclId.id) (generics : generic_args) : unit = let use_brackets = inside && generics <> empty_generic_args in F.pp_open_hvbox fmt ctx.indent_incr; if use_brackets then F.pp_print_string fmt "("; @@ -232,9 +236,9 @@ let fun_builtin_filter_types (id : FunDeclId.id) (types : 'a list) As a pattern can introduce new variables, we return an extraction context updated with new bindings. *) -let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (is_let : bool) (inside : bool) ?(with_type = false) (v : typed_pattern) : - extraction_ctx = +let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (is_let : bool) (inside : bool) ?(with_type = false) + (v : typed_pattern) : extraction_ctx = if with_type then F.pp_print_string fmt "("; let inside = inside && not with_type in let ctx = @@ -254,8 +258,8 @@ let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F let extract_value ctx inside v = extract_typed_pattern meta ctx fmt is_let inside v in - extract_adt_g_value meta extract_value fmt ctx is_let inside av.variant_id - av.field_values v.ty + extract_adt_g_value meta extract_value fmt ctx is_let inside + av.variant_id av.field_values v.ty in if with_type then ( F.pp_print_space fmt (); @@ -267,8 +271,8 @@ let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F (** Return true if we need to wrap a succession of let-bindings in a [do ...] block (because some of them are monadic) *) -let lets_require_wrap_in_do (meta : Meta.meta) (lets : (bool * typed_pattern * texpression) list) : - bool = +let lets_require_wrap_in_do (meta : Meta.meta) + (lets : (bool * typed_pattern * texpression) list) : bool = match !backend with | Lean -> (* For Lean, we wrap in a block iff at least one of the let-bindings is monadic *) @@ -276,7 +280,8 @@ let lets_require_wrap_in_do (meta : Meta.meta) (lets : (bool * typed_pattern * t | HOL4 -> (* HOL4 is similar to HOL4, but we add a sanity check *) let wrap_in_do = List.exists (fun (m, _, _) -> m) lets in - if wrap_in_do then sanity_check (List.for_all (fun (m, _, _) -> m) lets) meta; + if wrap_in_do then + sanity_check (List.for_all (fun (m, _, _) -> m) lets) meta; wrap_in_do | FStar | Coq -> false @@ -290,8 +295,8 @@ let lets_require_wrap_in_do (meta : Meta.meta) (lets : (bool * typed_pattern * t - application argument: [f (exp)] - match/if scrutinee: [if exp then _ else _]/[match exp | _ -> _] *) -let rec extract_texpression (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (e : texpression) : unit = +let rec extract_texpression (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (e : texpression) : unit = match e.e with | Var var_id -> let var_name = ctx_get_var meta var_id ctx in @@ -320,8 +325,8 @@ let rec extract_texpression (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.f (* Extract an application *or* a top-level qualif (function extraction has * to handle top-level qualifiers, so it seemed more natural to merge the * two cases) *) -and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (app : texpression) (args : texpression list) : unit = +and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (app : texpression) (args : texpression list) : unit = (* We don't do the same thing if the app is a top-level identifier (function, * ADT constructor...) or a "regular" expression *) match app.e with @@ -336,7 +341,8 @@ and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (i | AdtCons adt_cons_id -> extract_adt_cons meta ctx fmt inside adt_cons_id qualif.generics args | Proj proj -> - extract_field_projector meta ctx fmt inside app proj qualif.generics args + extract_field_projector meta ctx fmt inside app proj qualif.generics + args | TraitConst (trait_ref, const_name) -> extract_trait_ref meta ctx fmt TypeDeclId.Set.empty true trait_ref; let name = @@ -368,9 +374,9 @@ and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (i if inside then F.pp_print_string fmt ")" (** Subcase of the app case: function call *) -and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (fid : fun_or_op_id) (generics : generic_args) - (args : texpression list) : unit = +and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (fid : fun_or_op_id) + (generics : generic_args) (args : texpression list) : unit = match (fid, args) with | Unop unop, [ arg ] -> (* A unop can have *at most* one argument (the result can't be a function!). @@ -448,8 +454,9 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for if not method_id.is_provided then ( (* Required method *) - sanity_check (lp_id = None) trait_decl.meta ; - extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref; + sanity_check (lp_id = None) trait_decl.meta; + extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true + trait_ref; let fun_name = ctx_get_trait_method meta trait_ref.trait_decl_ref.trait_decl_id method_name ctx @@ -471,7 +478,8 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for Print the trait ref (to instantate the self clause) *) F.pp_print_space fmt (); - extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref + extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true + trait_ref | _ -> let fun_name = ctx_get_function meta fun_id ctx in F.pp_print_string fmt fun_name); @@ -498,11 +506,11 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for extract_generic_args meta ctx fmt TypeDeclId.Set.empty { generics with types }; (* if !Config.fail_hard then craise meta err - else *) + else *) save_error (Some meta) err; F.pp_print_string fmt - "(\"ERROR: ill-formed builtin: invalid number of filtering \ - arguments\")"); + "(\"ERROR: ill-formed builtin: invalid number of filtering \ + arguments\")"); (* Print the arguments *) List.iter (fun ve -> @@ -514,18 +522,17 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for (* Return *) if inside then F.pp_print_string fmt ")" | (Unop _ | Binop _), _ -> - craise - meta - ("Unreachable:\n" ^ "Function: " ^ show_fun_or_op_id fid - ^ ",\nNumber of arguments: " - ^ string_of_int (List.length args) - ^ ",\nArguments: " - ^ String.concat " " (List.map show_texpression args)) + craise meta + ("Unreachable:\n" ^ "Function: " ^ show_fun_or_op_id fid + ^ ",\nNumber of arguments: " + ^ string_of_int (List.length args) + ^ ",\nArguments: " + ^ String.concat " " (List.map show_texpression args)) (** Subcase of the app case: ADT constructor *) -and extract_adt_cons (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (adt_cons : adt_cons_id) (generics : generic_args) (args : texpression list) - : unit = +and extract_adt_cons (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (adt_cons : adt_cons_id) + (generics : generic_args) (args : texpression list) : unit = let e_ty = TAdt (adt_cons.adt_id, generics) in let is_single_pat = false in let _ = @@ -538,9 +545,10 @@ and extract_adt_cons (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatte () (** Subcase of the app case: ADT field projector. *) -and extract_field_projector (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (original_app : texpression) (proj : projection) - (_generics : generic_args) (args : texpression list) : unit = +and extract_field_projector (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (original_app : texpression) + (proj : projection) (_generics : generic_args) (args : texpression list) : + unit = (* We isolate the first argument (if there is), in order to pretty print the * projection ([x.field] instead of [MkAdt?.field x] *) match args with @@ -638,14 +646,14 @@ and extract_field_projector (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.f (* No argument: shouldn't happen *) craise meta "Unreachable" -and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (xl : typed_pattern list) (e : texpression) : unit = +and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (xl : typed_pattern list) (e : texpression) : unit = (* Open a box for the abs expression *) F.pp_open_hovbox fmt ctx.indent_incr; (* Open parentheses *) if inside then F.pp_print_string fmt "("; (* Print the lambda - note that there should always be at least one variable *) - sanity_check (xl <> []) meta ; + sanity_check (xl <> []) meta; F.pp_print_string fmt "fun"; let with_type = !backend = Coq in let ctx = @@ -666,8 +674,8 @@ and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (* Close the box for the abs expression *) F.pp_close_box fmt () -and extract_lets (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (e : texpression) : unit = +and extract_lets (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (e : texpression) : unit = (* Destruct the lets. Note that in the case of HOL4, we stop destructing the lets if at some point @@ -804,8 +812,8 @@ and extract_lets (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) ( (* Close the box for the whole expression *) F.pp_close_box fmt () -and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) - (scrut : texpression) (body : switch_body) : unit = +and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (_inside : bool) (scrut : texpression) (body : switch_body) : unit = (* Remark: we don't use the [inside] parameter because we extract matches in a conservative manner: we always make sure they are parenthesized/delimited with keywords such as [end] *) @@ -823,7 +831,9 @@ and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "if"; if !backend = Lean && ctx.use_dep_ite then F.pp_print_string fmt " h:"; F.pp_print_space fmt (); - let scrut_inside = PureUtils.texpression_requires_parentheses meta scrut in + let scrut_inside = + PureUtils.texpression_requires_parentheses meta scrut + in extract_texpression meta ctx fmt scrut_inside scrut; (* Close the box for the [if e] *) F.pp_close_box fmt (); @@ -837,7 +847,9 @@ and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) F.pp_open_hovbox fmt 0; let then_or_else = if is_then then "then" else "else" in F.pp_print_string fmt then_or_else; - let parenth = PureUtils.texpression_requires_parentheses meta e_branch in + let parenth = + PureUtils.texpression_requires_parentheses meta e_branch + in (* Open the parenthesized expression *) let print_space_after_parenth = if parenth then ( @@ -889,7 +901,9 @@ and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) in F.pp_print_string fmt match_begin; F.pp_print_space fmt (); - let scrut_inside = PureUtils.texpression_requires_parentheses meta scrut in + let scrut_inside = + PureUtils.texpression_requires_parentheses meta scrut + in extract_texpression meta ctx fmt scrut_inside scrut; F.pp_print_space fmt (); let match_scrut_end = @@ -940,11 +954,12 @@ and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (* Close the box for the whole expression *) F.pp_close_box fmt () -and extract_StructUpdate (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (e_ty : ty) (supd : struct_update) : unit = +and extract_StructUpdate (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (e_ty : ty) (supd : struct_update) : + unit = (* We can't update a subset of the fields in Coq (i.e., we can do [{| x:= 3; y := 4 |}], but there is no syntax for [{| s with x := 3 |}]) *) - sanity_check (!backend <> Coq || supd.init = None) meta ; + sanity_check (!backend <> Coq || supd.init = None) meta; (* In the case of HOL4, records with no fields are not supported and are thus extracted to unit. We need to check that by looking up the definition *) let extract_as_unit = @@ -1133,8 +1148,8 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) (* Open a box for the generics *) F.pp_open_hovbox fmt 0; (let space = Some space in - extract_generic_params def.meta ctx fmt TypeDeclId.Set.empty ~space ~trait_decl - def.signature.generics type_params cg_params trait_clauses); + extract_generic_params def.meta ctx fmt TypeDeclId.Set.empty ~space + ~trait_decl def.signature.generics type_params cg_params trait_clauses); (* Close the box for the generics *) F.pp_close_box fmt (); (* The input parameters - note that doing this adds bindings to the context *) @@ -1187,8 +1202,8 @@ let assert_backend_supports_decreases_clauses (meta : Meta.meta) = match !backend with | FStar | Lean -> () | _ -> - craise - meta "Decreases clauses are only supported for the Lean and F* backends" + craise meta + "Decreases clauses are only supported for the Lean and F* backends" (** Extract a decreases clause function template body. @@ -1208,10 +1223,14 @@ let assert_backend_supports_decreases_clauses (meta : Meta.meta) = *) let extract_template_fstar_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - cassert (!backend = FStar) def.meta "The generation of template decrease clauses is only supported for the F* backend"; + cassert (!backend = FStar) def.meta + "The generation of template decrease clauses is only supported for the F* \ + backend"; (* Retrieve the function name *) - let def_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in + let def_name = + ctx_get_termination_measure def.meta def.def_id def.loop_id ctx + in (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) @@ -1273,12 +1292,16 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) *) let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - cassert (!backend = Lean) def.meta "The generation of template termination and decreasing clauses is only supported for the Lean backend" ; + cassert (!backend = Lean) def.meta + "The generation of template termination and decreasing clauses is only \ + supported for the Lean backend"; (* * Extract a template for the termination measure *) (* Retrieve the function name *) - let def_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in + let def_name = + ctx_get_termination_measure def.meta def.def_id def.loop_id ctx + in let def_body = Option.get def.body in (* Add a break before *) F.pp_print_break fmt 0 0; @@ -1396,7 +1419,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - sanity_check (not def.is_global_decl_body) def.meta ; + sanity_check (not def.is_global_decl_body) def.meta; (* Retrieve the function name *) let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in (* Add a break before *) @@ -1489,7 +1512,9 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open a box for the decreases term *) F.pp_open_hovbox fmt ctx.indent_incr; (* The name of the decrease clause *) - let decr_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in + let decr_name = + ctx_get_termination_measure def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt decr_name; (* Print the generic parameters - TODO: we do this many times, we should have a helper to factor it out *) @@ -1545,7 +1570,9 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open a box for the body *) F.pp_open_hvbox fmt 0; (* Extract the body *) - let _ = extract_texpression def.meta ctx_body fmt false (Option.get def.body).body in + let _ = + extract_texpression def.meta ctx_body fmt false (Option.get def.body).body + in (* Close the box for the body *) F.pp_close_box fmt ()); (* Close the inner box for the definition *) @@ -1604,7 +1631,9 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_break fmt 0 0; (* Open a box for the [decreasing by ...] *) F.pp_open_hvbox fmt ctx.indent_incr; - let decreases_name = ctx_get_decreases_proof def.meta def.def_id def.loop_id ctx in + let decreases_name = + ctx_get_decreases_proof def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt "decreasing_by"; F.pp_print_space fmt (); F.pp_open_hvbox fmt ctx.indent_incr; @@ -1643,7 +1672,10 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = (* Retrieve the definition name *) let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in - cassert (def.signature.generics.const_generics = []) def.meta "Constant generics are not supported yet when generating code for HOL4"; + cassert + (def.signature.generics.const_generics = []) + def.meta + "Constant generics are not supported yet when generating code for HOL4"; (* Add the type/const gen parameters - note that we need those bindings only for the generation of the type (they are not top-level) *) let ctx, _, _, _ = @@ -1689,7 +1721,7 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - sanity_check (not def.is_global_decl_body) def.meta ; + sanity_check (not def.is_global_decl_body) def.meta; (* We treat HOL4 opaque functions in a specific manner *) if !backend = HOL4 && Option.is_none def.body then extract_fun_decl_hol4_opaque ctx fmt def @@ -1702,10 +1734,10 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) extracted to two declarations, and we can actually factor out the generation of those declarations. See {!extract_global_decl} for more explanations. *) -let extract_global_decl_body_gen (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (kind : decl_kind) (name : string) (generics : generic_params) - (type_params : string list) (cg_params : string list) - (trait_clauses : string list) (ty : ty) +let extract_global_decl_body_gen (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (kind : decl_kind) (name : string) + (generics : generic_params) (type_params : string list) + (cg_params : string list) (trait_clauses : string list) (ty : ty) (extract_body : (F.formatter -> unit) Option.t) : unit = let is_opaque = Option.is_none extract_body in @@ -1794,8 +1826,9 @@ let extract_global_decl_body_gen (meta : Meta.meta) (ctx : extraction_ctx) (fmt Remark (SH): having to treat this specific case separately is very annoying, but I could not find a better way. *) -let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (name : string) (generics : generic_params) (ty : ty) : unit = +let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (name : string) (generics : generic_params) (ty : ty) : + unit = (* TODO: non-empty generics *) assert (generics = empty_generic_params); (* Open the definition boxe (depth=0) *) @@ -1838,7 +1871,6 @@ let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) (f *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : global_decl) (body : fun_decl) (interface : bool) : unit = - let meta = body.meta in cassert body.is_global_decl_body body.meta "TODO: Error message"; cassert (body.signature.inputs = []) body.meta "TODO: Error message"; @@ -1857,7 +1889,9 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) let decl_name = ctx_get_global meta global.def_id ctx in let body_name = - ctx_get_function meta (FromLlbc (Pure.FunId (FRegular global.body_id), None)) ctx + ctx_get_function meta + (FromLlbc (Pure.FunId (FRegular global.body_id), None)) + ctx in let decl_ty, body_ty = let ty = body.signature.output in @@ -1867,8 +1901,8 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) in (* Add the type parameters *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params meta global.llbc_name global.llbc_generics global.generics - ctx + ctx_add_generic_params meta global.llbc_name global.llbc_generics + global.generics ctx in match body.body with | None -> @@ -1957,7 +1991,9 @@ let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (cid, cname) -> - ctx_add trait_decl.meta (TraitParentClauseId (trait_decl.def_id, cid)) cname ctx) + ctx_add trait_decl.meta + (TraitParentClauseId (trait_decl.def_id, cid)) + cname ctx) ctx clause_names (** Similar to {!extract_trait_decl_register_names} *) @@ -1990,7 +2026,9 @@ let extract_trait_decl_register_constant_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (item_name, name) -> - ctx_add trait_decl.meta (TraitItemId (trait_decl.def_id, item_name)) name ctx) + ctx_add trait_decl.meta + (TraitItemId (trait_decl.def_id, item_name)) + name ctx) ctx constant_names (** Similar to {!extract_trait_decl_register_names} *) @@ -2049,11 +2087,13 @@ let extract_trait_decl_type_names (ctx : extraction_ctx) List.fold_left (fun ctx (item_name, (type_name, clauses)) -> let ctx = - ctx_add trait_decl.meta (TraitItemId (trait_decl.def_id, item_name)) type_name ctx + ctx_add trait_decl.meta + (TraitItemId (trait_decl.def_id, item_name)) + type_name ctx in List.fold_left (fun ctx (clause_id, clause_name) -> - ctx_add trait_decl.meta + ctx_add trait_decl.meta (TraitItemClauseId (trait_decl.def_id, item_name, clause_id)) clause_name ctx) ctx clauses) @@ -2105,7 +2145,9 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (item_name, fun_name) -> - ctx_add trait_decl.meta (TraitMethodId (trait_decl.def_id, item_name)) fun_name ctx) + ctx_add trait_decl.meta + (TraitMethodId (trait_decl.def_id, item_name)) + fun_name ctx) ctx method_names (** Similar to {!extract_type_decl_register_names} *) @@ -2125,8 +2167,11 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) ctx_compute_trait_decl_constructor ctx trait_decl ) | Some info -> (info.extract_name, info.constructor) in - let ctx = ctx_add trait_decl.meta (TraitDeclId trait_decl.def_id) trait_name ctx in - ctx_add trait_decl.meta (TraitDeclConstructorId trait_decl.def_id) trait_constructor ctx + let ctx = + ctx_add trait_decl.meta (TraitDeclId trait_decl.def_id) trait_name ctx + in + ctx_add trait_decl.meta (TraitDeclConstructorId trait_decl.def_id) + trait_constructor ctx in (* Parent clauses *) let ctx = @@ -2180,7 +2225,9 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) in (* For now we do not support overriding provided methods *) - cassert (trait_impl.provided_methods = []) trait_impl.meta "Overriding provided methods is not supported yet"; + cassert + (trait_impl.provided_methods = []) + trait_impl.meta "Overriding provided methods is not supported yet"; (* Everything is taken care of by {!extract_trait_decl_register_names} *but* the name of the implementation itself *) (* Compute the name *) @@ -2254,7 +2301,8 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.meta f.llbc_name f.signature.llbc_generics generics ctx + ctx_add_generic_params decl.meta f.llbc_name f.signature.llbc_generics + generics ctx in let backend_uses_forall = match !backend with Coq | Lean -> true | FStar | HOL4 -> false @@ -2321,10 +2369,11 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics generics ctx + ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics generics + ctx in - extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty generics type_params - cg_params trait_clauses; + extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty generics + type_params cg_params trait_clauses; F.pp_print_space fmt (); if is_empty && !backend = FStar then ( @@ -2379,11 +2428,13 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun clause -> let item_name = - ctx_get_trait_item_clause decl.meta decl.def_id name clause.clause_id ctx + ctx_get_trait_item_clause decl.meta decl.def_id name + clause.clause_id ctx in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty + clause in extract_trait_decl_item ctx fmt item_name ty) clauses) @@ -2398,7 +2449,8 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty + clause in extract_trait_decl_item ctx fmt item_name ty) decl.parent_clauses; @@ -2453,7 +2505,8 @@ let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun clause -> let item_name = - ctx_get_trait_item_clause decl.meta decl.def_id name clause.clause_id ctx + ctx_get_trait_item_clause decl.meta decl.def_id name + clause.clause_id ctx in extract_coq_arguments_instruction ctx fmt item_name num_params) clauses) @@ -2470,7 +2523,9 @@ let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun (item_name, _) -> (* Extract the items *) - let item_name = ctx_get_trait_method decl.meta decl.def_id item_name ctx in + let item_name = + ctx_get_trait_method decl.meta decl.def_id item_name ctx + in extract_coq_arguments_instruction ctx fmt item_name num_params) decl.required_methods; (* Add a space *) @@ -2535,12 +2590,12 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, f_tys, f_cgs, f_tcs = - ctx_add_generic_params impl.meta f.llbc_name f.signature.llbc_generics f_generics - ctx + ctx_add_generic_params impl.meta f.llbc_name f.signature.llbc_generics + f_generics ctx in let use_forall = f_generics <> empty_generic_params in - extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty ~use_forall f_generics - f_tys f_cgs f_tcs; + extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty ~use_forall + f_generics f_tys f_cgs f_tcs; if use_forall then F.pp_print_string fmt ","; (* Extract the function call *) F.pp_print_space fmt (); @@ -2607,17 +2662,19 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params impl.meta impl.llbc_name impl.llbc_generics impl.generics ctx + ctx_add_generic_params impl.meta impl.llbc_name impl.llbc_generics + impl.generics ctx in let all_generics = (type_params, cg_params, trait_clauses) in - extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty impl.generics type_params - cg_params trait_clauses; + extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty impl.generics + type_params cg_params trait_clauses; (* Print the type *) F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_trait_decl_ref impl.meta ctx fmt TypeDeclId.Set.empty false impl.impl_trait; + extract_trait_decl_ref impl.meta ctx fmt TypeDeclId.Set.empty false + impl.impl_trait; (* When checking if the trait impl is empty: we ignore the provided methods, because for now they are extracted separately *) @@ -2630,7 +2687,9 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt ()) else if is_empty && !Config.backend = Coq then ( (* Coq is not very good at infering constructors *) - let cons = ctx_get_trait_constructor impl.meta impl.impl_trait.trait_decl_id ctx in + let cons = + ctx_get_trait_constructor impl.meta impl.impl_trait.trait_decl_id ctx + in F.pp_print_string fmt (":= " ^ cons ^ "."); (* Outer box *) F.pp_close_box fmt ()) @@ -2694,11 +2753,13 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) TraitClauseId.iteri (fun clause_id trait_ref -> let item_name = - ctx_get_trait_item_clause impl.meta trait_decl_id name clause_id ctx + ctx_get_trait_item_clause impl.meta trait_decl_id name clause_id + ctx in let ty () = F.pp_print_space fmt (); - extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false trait_ref + extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false + trait_ref in extract_trait_impl_item ctx fmt item_name ty) trait_refs) @@ -2712,7 +2773,8 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false trait_ref + extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false + trait_ref in extract_trait_impl_item ctx fmt item_name ty) impl.parent_trait_refs; @@ -2775,7 +2837,9 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "assert_norm"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + let fun_name = + ctx_get_local_function def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2783,13 +2847,17 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "="; F.pp_print_space fmt (); - let success = ctx_get_variant def.meta (TAssumed TResult) result_return_id ctx in + let success = + ctx_get_variant def.meta (TAssumed TResult) result_return_id ctx + in F.pp_print_string fmt (success ^ " ())") | Coq -> F.pp_print_string fmt "Check"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + let fun_name = + ctx_get_local_function def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2800,7 +2868,9 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "#assert"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + let fun_name = + ctx_get_local_function def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2808,12 +2878,16 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "=="; F.pp_print_space fmt (); - let success = ctx_get_variant def.meta (TAssumed TResult) result_return_id ctx in + let success = + ctx_get_variant def.meta (TAssumed TResult) result_return_id ctx + in F.pp_print_string fmt (success ^ " ())") | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; F.pp_print_string fmt "“"; - let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + let fun_name = + ctx_get_local_function def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index aae11f19..b7255dbc 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -237,7 +237,7 @@ module IdSet = Collections.MakeSet (IdOrderedType) *) type names_map = { id_to_name : string IdMap.t; - name_to_id : id StringMap.t; + name_to_id : (id * Meta.meta option) StringMap.t; (** The name to id map is used to look for name clashes, and generate nice debugging messages: if there is a name clash, it is useful to know precisely which identifiers are mapped to the same name... @@ -253,8 +253,8 @@ let empty_names_map : names_map = } (** Small helper to report name collision *) -let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) - (name : string) : unit = +let report_name_collision (id_to_string : id -> string) + ((id1, meta) : id * Meta.meta option) (id2 : id) (name : string) : unit = let id1 = "\n- " ^ id_to_string id1 in let id2 = "\n- " ^ id_to_string id2 in let err = @@ -263,9 +263,10 @@ let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) ^ "\nYou may want to rename some of your definitions, or report an issue." in (* If we fail hard on errors, raise an exception *) - save_error None err + save_error meta err -let names_map_get_id_from_name (name : string) (nm : names_map) : id option = +let names_map_get_id_from_name (name : string) (nm : names_map) : + (id * meta option) option = StringMap.find_opt name nm.name_to_id let names_map_check_collision (id_to_string : id -> string) (id : id) @@ -290,13 +291,13 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) (* Check if there is a clash *) names_map_check_collision id_to_string id name nm; (* Sanity check *) - if StringSet.mem name nm.names_set then ( - let err = - "Error when registering the name for id: " ^ id_to_string id - ^ ":\nThe chosen name is already in the names set: " ^ name - in - (* If we fail hard on errors, raise an exception *) - save_error None err); + (if StringSet.mem name nm.names_set then + let err = + "Error when registering the name for id: " ^ id_to_string id + ^ ":\nThe chosen name is already in the names set: " ^ name + in + (* If we fail hard on errors, raise an exception *) + save_error None err); (* Insert *) names_map_add_unchecked id name nm @@ -423,8 +424,8 @@ let names_maps_add (id_to_string : id -> string) (id : id) (name : string) (** The [id_to_string] function to print nice debugging messages if there are collisions *) -let names_maps_get (meta : Meta.meta option) (id_to_string : id -> string) (id : id) (nm : names_maps) : - string = +let names_maps_get (meta : Meta.meta option) (id_to_string : id -> string) + (id : id) (nm : names_maps) : string = (* We do not use the same name map if we allow/disallow collisions *) let map_to_string (m : string IdMap.t) : string = "[\n" @@ -588,16 +589,17 @@ let fun_id_to_string (ctx : extraction_ctx) = PrintPure.regular_fun_id_to_string (extraction_ctx_to_fmt_env ctx) let adt_variant_to_string (meta : Meta.meta option) (ctx : extraction_ctx) = - PrintPure.adt_variant_to_string ~meta:meta (extraction_ctx_to_fmt_env ctx) + PrintPure.adt_variant_to_string ~meta (extraction_ctx_to_fmt_env ctx) let adt_field_to_string (meta : Meta.meta option) (ctx : extraction_ctx) = - PrintPure.adt_field_to_string ~meta:meta (extraction_ctx_to_fmt_env ctx) + PrintPure.adt_field_to_string ~meta (extraction_ctx_to_fmt_env ctx) (** Debugging function, used when communicating name collisions to the user, and also to print ids for internal debugging (in case of lookup miss for instance). *) -let id_to_string (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : string = +let id_to_string (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : + string = let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = let trait_name = trait_decl_id_to_string ctx id in "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" @@ -655,95 +657,108 @@ let id_to_string (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : st trait_decl_id_to_string trait_decl_id ^ ", method name: " ^ fun_name | TraitSelfClauseId -> "trait_self_clause" -let ctx_add (meta : Meta.meta) (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = +let ctx_add (meta : Meta.meta) (id : id) (name : string) (ctx : extraction_ctx) + : extraction_ctx = let id_to_string (id : id) : string = id_to_string (Some meta) id ctx in let names_maps = names_maps_add id_to_string id name ctx.names_maps in { ctx with names_maps } -let ctx_get (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : string = +let ctx_get (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : string + = let id_to_string (id : id) : string = id_to_string meta id ctx in names_maps_get meta id_to_string id ctx.names_maps -let ctx_get_global (meta : Meta.meta) (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = +let ctx_get_global (meta : Meta.meta) (id : A.GlobalDeclId.id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (GlobalId id) ctx -let ctx_get_function (meta : Meta.meta) (id : fun_id) (ctx : extraction_ctx) : string = +let ctx_get_function (meta : Meta.meta) (id : fun_id) (ctx : extraction_ctx) : + string = ctx_get (Some meta) (FunId id) ctx -let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) (lp : LoopId.id option) - (ctx : extraction_ctx) : string = +let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) + (lp : LoopId.id option) (ctx : extraction_ctx) : string = ctx_get_function meta (FromLlbc (FunId (FRegular id), lp)) ctx -let ctx_get_type (meta : Meta.meta option) (id : type_id) (ctx : extraction_ctx) : string = +let ctx_get_type (meta : Meta.meta option) (id : type_id) (ctx : extraction_ctx) + : string = sanity_check_opt_meta (id <> TTuple) meta; ctx_get meta (TypeId id) ctx -let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) (ctx : extraction_ctx) : string = +let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) + (ctx : extraction_ctx) : string = ctx_get_type (Some meta) (TAdtId id) ctx -let ctx_get_assumed_type (meta : Meta.meta option) (id : assumed_ty) (ctx : extraction_ctx) : string = +let ctx_get_assumed_type (meta : Meta.meta option) (id : assumed_ty) + (ctx : extraction_ctx) : string = ctx_get_type meta (TAssumed id) ctx -let ctx_get_trait_constructor (meta : Meta.meta) (id : trait_decl_id) (ctx : extraction_ctx) : - string = +let ctx_get_trait_constructor (meta : Meta.meta) (id : trait_decl_id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitDeclConstructorId id) ctx -let ctx_get_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : string = +let ctx_get_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : string + = ctx_get (Some meta) TraitSelfClauseId ctx -let ctx_get_trait_decl (meta : Meta.meta) (id : trait_decl_id) (ctx : extraction_ctx) : string = +let ctx_get_trait_decl (meta : Meta.meta) (id : trait_decl_id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitDeclId id) ctx -let ctx_get_trait_impl (meta : Meta.meta) (id : trait_impl_id) (ctx : extraction_ctx) : string = +let ctx_get_trait_impl (meta : Meta.meta) (id : trait_impl_id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitImplId id) ctx -let ctx_get_trait_item (meta : Meta.meta) (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = - ctx_get (Some meta) (TraitItemId (id, item_name)) ctx +let ctx_get_trait_item (meta : Meta.meta) (id : trait_decl_id) + (item_name : string) (ctx : extraction_ctx) : string = + ctx_get (Some meta) (TraitItemId (id, item_name)) ctx -let ctx_get_trait_const (meta : Meta.meta) (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = +let ctx_get_trait_const (meta : Meta.meta) (id : trait_decl_id) + (item_name : string) (ctx : extraction_ctx) : string = ctx_get_trait_item meta id item_name ctx -let ctx_get_trait_type (meta : Meta.meta) (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = +let ctx_get_trait_type (meta : Meta.meta) (id : trait_decl_id) + (item_name : string) (ctx : extraction_ctx) : string = ctx_get_trait_item meta id item_name ctx -let ctx_get_trait_method (meta : Meta.meta) (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = +let ctx_get_trait_method (meta : Meta.meta) (id : trait_decl_id) + (item_name : string) (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitMethodId (id, item_name)) ctx -let ctx_get_trait_parent_clause (meta : Meta.meta) (id : trait_decl_id) (clause : trait_clause_id) - (ctx : extraction_ctx) : string = +let ctx_get_trait_parent_clause (meta : Meta.meta) (id : trait_decl_id) + (clause : trait_clause_id) (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitParentClauseId (id, clause)) ctx -let ctx_get_trait_item_clause (meta : Meta.meta) (id : trait_decl_id) (item : string) - (clause : trait_clause_id) (ctx : extraction_ctx) : string = +let ctx_get_trait_item_clause (meta : Meta.meta) (id : trait_decl_id) + (item : string) (clause : trait_clause_id) (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitItemClauseId (id, item, clause)) ctx -let ctx_get_var (meta : Meta.meta) (id : VarId.id) (ctx : extraction_ctx) : string = +let ctx_get_var (meta : Meta.meta) (id : VarId.id) (ctx : extraction_ctx) : + string = ctx_get (Some meta) (VarId id) ctx -let ctx_get_type_var (meta : Meta.meta) (id : TypeVarId.id) (ctx : extraction_ctx) : string = +let ctx_get_type_var (meta : Meta.meta) (id : TypeVarId.id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (TypeVarId id) ctx -let ctx_get_const_generic_var (meta : Meta.meta) (id : ConstGenericVarId.id) (ctx : extraction_ctx) - : string = +let ctx_get_const_generic_var (meta : Meta.meta) (id : ConstGenericVarId.id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (ConstGenericVarId id) ctx -let ctx_get_local_trait_clause (meta : Meta.meta) (id : TraitClauseId.id) (ctx : extraction_ctx) : - string = +let ctx_get_local_trait_clause (meta : Meta.meta) (id : TraitClauseId.id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (LocalTraitClauseId id) ctx let ctx_get_field (meta : Meta.meta) (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = ctx_get (Some meta) (FieldId (type_id, field_id)) ctx -let ctx_get_struct (meta : Meta.meta) (def_id : type_id) (ctx : extraction_ctx) : string = +let ctx_get_struct (meta : Meta.meta) (def_id : type_id) (ctx : extraction_ctx) + : string = ctx_get (Some meta) (StructId def_id) ctx -let ctx_get_variant (meta : Meta.meta) (def_id : type_id) (variant_id : VariantId.id) - (ctx : extraction_ctx) : string = +let ctx_get_variant (meta : Meta.meta) (def_id : type_id) + (variant_id : VariantId.id) (ctx : extraction_ctx) : string = ctx_get (Some meta) (VariantId (def_id, variant_id)) ctx let ctx_get_decreases_proof (meta : Meta.meta) (def_id : A.FunDeclId.id) @@ -1187,11 +1202,10 @@ let type_decl_kind_to_qualif (meta : Meta.meta) (kind : decl_kind) (* This is for traits *) Some "Record" | _ -> - craise - meta - ("Unexpected: (" ^ show_decl_kind kind ^ ", " - ^ Print.option_to_string show_type_decl_kind type_kind - ^ ")")) + craise meta + ("Unexpected: (" ^ show_decl_kind kind ^ ", " + ^ Print.option_to_string show_type_decl_kind type_kind + ^ ")")) | Lean -> ( match kind with | SingleNonRec -> ( @@ -1264,20 +1278,20 @@ let name_last_elem_as_ident (meta : Meta.meta) (n : llbc_name) : string = we remove it. We ignore disambiguators (there may be collisions, but we check if there are). *) -let ctx_prepare_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : llbc_name = +let ctx_prepare_name (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) : llbc_name = (* Rmk.: initially we only filtered the disambiguators equal to 0 *) match name with | (PeIdent (crate, _) as id) :: name -> if crate = ctx.crate.name then name else id :: name | _ -> - craise - meta - ("Unexpected name shape: " - ^ TranslateCore.name_to_string ctx.trans_ctx name) + craise meta + ("Unexpected name shape: " + ^ TranslateCore.name_to_string ctx.trans_ctx name) (** Helper *) -let ctx_compute_simple_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : - string list = +let ctx_compute_simple_name (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) : string list = (* Rmk.: initially we only filtered the disambiguators equal to 0 *) let name = ctx_prepare_name meta ctx name in name_to_simple_name ctx.trans_ctx name @@ -1287,12 +1301,13 @@ let ctx_compute_simple_type_name = ctx_compute_simple_name (** Helper *) -let ctx_compute_type_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : - string = +let ctx_compute_type_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) : string = flatten_name (ctx_compute_simple_type_name meta ctx name) (** Provided a basename, compute a type name. *) -let ctx_compute_type_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) = +let ctx_compute_type_name (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) = let name = ctx_compute_type_name_no_suffix meta ctx name in match !backend with | FStar -> StringUtils.lowercase_first_letter (name ^ "_t") @@ -1310,8 +1325,9 @@ let ctx_compute_type_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc access then causes trouble because not all provers accept syntax like [x.3] where [x] is a tuple. *) -let ctx_compute_field_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name : llbc_name) - (field_id : FieldId.id) (field_name : string option) : string = +let ctx_compute_field_name (meta : Meta.meta) (ctx : extraction_ctx) + (def_name : llbc_name) (field_id : FieldId.id) (field_name : string option) + : string = let field_name_s = match field_name with | Some field_name -> field_name @@ -1335,8 +1351,8 @@ let ctx_compute_field_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name : - type name - variant name *) -let ctx_compute_variant_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name : llbc_name) - (variant : string) : string = +let ctx_compute_variant_name (meta : Meta.meta) (ctx : extraction_ctx) + (def_name : llbc_name) (variant : string) : string = match !backend with | FStar | Coq | HOL4 -> let variant = to_camel_case variant in @@ -1357,13 +1373,13 @@ let ctx_compute_variant_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name Inputs: - type name *) -let ctx_compute_struct_constructor (meta : Meta.meta) (ctx : extraction_ctx) (basename : llbc_name) - : string = +let ctx_compute_struct_constructor (meta : Meta.meta) (ctx : extraction_ctx) + (basename : llbc_name) : string = let tname = ctx_compute_type_name meta ctx basename in ExtractBuiltin.mk_struct_constructor tname -let ctx_compute_fun_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (fname : llbc_name) : - string = +let ctx_compute_fun_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) + (fname : llbc_name) : string = let fname = ctx_compute_simple_name meta ctx fname in (* TODO: don't convert to snake case for Coq, HOL4, F* *) let fname = flatten_name fname in @@ -1372,10 +1388,13 @@ let ctx_compute_fun_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (fn | Lean -> fname (** Provided a basename, compute the name of a global declaration. *) -let ctx_compute_global_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : string = +let ctx_compute_global_name (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) : string = match !Config.backend with | Coq | FStar | HOL4 -> - let parts = List.map to_snake_case (ctx_compute_simple_name meta ctx name) in + let parts = + List.map to_snake_case (ctx_compute_simple_name meta ctx name) + in String.concat "_" parts | Lean -> flatten_name (ctx_compute_simple_name meta ctx name) @@ -1408,8 +1427,9 @@ let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) : string = - loop id (if pertinent) TODO: use the fun id for the assumed functions. *) -let ctx_compute_fun_name (meta : Meta.meta) (ctx : extraction_ctx) (fname : llbc_name) - (num_loops : int) (loop_id : LoopId.id option) : string = +let ctx_compute_fun_name (meta : Meta.meta) (ctx : extraction_ctx) + (fname : llbc_name) (num_loops : int) (loop_id : LoopId.id option) : string + = let fname = ctx_compute_fun_name_no_suffix meta ctx fname in (* Compute the suffix *) let suffix = default_fun_suffix num_loops loop_id in @@ -1568,9 +1588,9 @@ let ctx_compute_trait_type_clause_name (ctx : extraction_ctx) the same purpose as in [llbc_name]. - loop identifier, if this is for a loop *) -let ctx_compute_termination_measure_name (meta : Meta.meta) (ctx : extraction_ctx) - (_fid : A.FunDeclId.id) (fname : llbc_name) (num_loops : int) - (loop_id : LoopId.id option) : string = +let ctx_compute_termination_measure_name (meta : Meta.meta) + (ctx : extraction_ctx) (_fid : A.FunDeclId.id) (fname : llbc_name) + (num_loops : int) (loop_id : LoopId.id option) : string = let fname = ctx_compute_fun_name_no_suffix meta ctx fname in let lp_suffix = default_fun_loop_suffix num_loops loop_id in (* Compute the suffix *) @@ -1624,8 +1644,8 @@ let ctx_compute_decreases_proof_name (meta : Meta.meta) (ctx : extraction_ctx) if necessary to prevent name clashes: the burden of name clashes checks is thus on the caller's side. *) -let ctx_compute_var_basename (meta : Meta.meta) (ctx : extraction_ctx) (basename : string option) - (ty : ty) : string = +let ctx_compute_var_basename (meta : Meta.meta) (ctx : extraction_ctx) + (basename : string option) (ty : ty) : string = (* Small helper to derive var names from ADT type names. We do the following: @@ -1747,8 +1767,9 @@ let ctx_add_type_var (meta : Meta.meta) (basename : string) (id : TypeVarId.id) (ctx, name) (** Generate a unique const generic variable name and add it to the context *) -let ctx_add_const_generic_var (meta : Meta.meta) (basename : string) (id : ConstGenericVarId.id) - (ctx : extraction_ctx) : extraction_ctx * string = +let ctx_add_const_generic_var (meta : Meta.meta) (basename : string) + (id : ConstGenericVarId.id) (ctx : extraction_ctx) : extraction_ctx * string + = let name = ctx_compute_const_generic_var_basename ctx basename in let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index name @@ -1764,8 +1785,8 @@ let ctx_add_type_vars (meta : Meta.meta) (vars : (string * TypeVarId.id) list) ctx vars (** Generate a unique variable name and add it to the context *) -let ctx_add_var (meta : Meta.meta) (basename : string) (id : VarId.id) (ctx : extraction_ctx) : - extraction_ctx * string = +let ctx_add_var (meta : Meta.meta) (basename : string) (id : VarId.id) + (ctx : extraction_ctx) : extraction_ctx * string = let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename @@ -1774,7 +1795,8 @@ let ctx_add_var (meta : Meta.meta) (basename : string) (id : VarId.id) (ctx : ex (ctx, name) (** Generate a unique variable name for the trait self clause and add it to the context *) -let ctx_add_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : extraction_ctx * string = +let ctx_add_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : + extraction_ctx * string = let basename = trait_self_clause_basename in let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index @@ -1784,8 +1806,8 @@ let ctx_add_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : extrac (ctx, name) (** Generate a unique trait clause name and add it to the context *) -let ctx_add_local_trait_clause (meta : Meta.meta) (basename : string) (id : TraitClauseId.id) - (ctx : extraction_ctx) : extraction_ctx * string = +let ctx_add_local_trait_clause (meta : Meta.meta) (basename : string) + (id : TraitClauseId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename @@ -1802,14 +1824,15 @@ let ctx_add_vars (meta : Meta.meta) (vars : var list) (ctx : extraction_ctx) : ctx_add_var meta name v.id ctx) ctx vars -let ctx_add_type_params (meta : Meta.meta) (vars : type_var list) (ctx : extraction_ctx) : - extraction_ctx * string list = +let ctx_add_type_params (meta : Meta.meta) (vars : type_var list) + (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (var : type_var) -> ctx_add_type_var meta var.name var.index ctx) ctx vars -let ctx_add_const_generic_params (meta : Meta.meta) (vars : const_generic_var list) - (ctx : extraction_ctx) : extraction_ctx * string list = +let ctx_add_const_generic_params (meta : Meta.meta) + (vars : const_generic_var list) (ctx : extraction_ctx) : + extraction_ctx * string list = List.fold_left_map (fun ctx (var : const_generic_var) -> ctx_add_const_generic_var meta var.name var.index ctx) @@ -1824,9 +1847,10 @@ let ctx_add_const_generic_params (meta : Meta.meta) (vars : const_generic_var li pretty names for the trait clauses. See {!ctx_compute_trait_clause_name} for additional information. *) -let ctx_add_local_trait_clauses (meta : Meta.meta) (current_def_name : Types.name) - (llbc_generics : Types.generic_params) (clauses : trait_clause list) - (ctx : extraction_ctx) : extraction_ctx * string list = +let ctx_add_local_trait_clauses (meta : Meta.meta) + (current_def_name : Types.name) (llbc_generics : Types.generic_params) + (clauses : trait_clause list) (ctx : extraction_ctx) : + extraction_ctx * string list = List.fold_left_map (fun ctx (c : trait_clause) -> let basename = @@ -1853,17 +1877,20 @@ let ctx_add_generic_params (meta : Meta.meta) (current_def_name : Types.name) let ctx, tys = ctx_add_type_params meta types ctx in let ctx, cgs = ctx_add_const_generic_params meta const_generics ctx in let ctx, tcs = - ctx_add_local_trait_clauses meta current_def_name llbc_generics trait_clauses ctx + ctx_add_local_trait_clauses meta current_def_name llbc_generics + trait_clauses ctx in (ctx, tys, cgs, tcs) let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx_compute_decreases_proof_name def.meta ctx def.def_id def.llbc_name def.num_loops - def.loop_id + ctx_compute_decreases_proof_name def.meta ctx def.def_id def.llbc_name + def.num_loops def.loop_id in - ctx_add def.meta (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx + ctx_add def.meta + (DecreasesProofId (FRegular def.def_id, def.loop_id)) + name ctx let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = @@ -1871,7 +1898,9 @@ let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : ctx_compute_termination_measure_name def.meta ctx def.def_id def.llbc_name def.num_loops def.loop_id in - ctx_add def.meta (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx + ctx_add def.meta + (TerminationMeasureId (FRegular def.def_id, def.loop_id)) + name ctx let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index c4e145a0..e9d6116f 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -32,7 +32,8 @@ end For impl blocks, we simply use the name of the type (without its arguments) if all the arguments are variables. *) -let pattern_to_extract_name (meta : Meta.meta option) (name : pattern) : string list = +let pattern_to_extract_name (meta : Meta.meta option) (name : pattern) : + string list = let c = { tgt = TkName } in let all_vars = let check (g : generic_arg) : bool = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 94acd08c..d785e299 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -15,7 +15,8 @@ include ExtractBase if it is made of an application (ex.: [U32 3]) - the constant value *) -let extract_literal (meta : Meta.meta) (fmt : F.formatter) (inside : bool) (cv : literal) : unit = +let extract_literal (meta : Meta.meta) (fmt : F.formatter) (inside : bool) + (cv : literal) : unit = match cv with | VScalar sv -> ( match !backend with @@ -187,9 +188,10 @@ let extract_unop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) - argument 0 - argument 1 *) -let extract_binop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (binop : E.binop) - (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = +let extract_binop (meta : Meta.meta) + (extract_expr : bool -> texpression -> unit) (fmt : F.formatter) + (inside : bool) (binop : E.binop) (int_ty : integer_type) + (arg0 : texpression) (arg1 : texpression) : unit = if inside then F.pp_print_string fmt "("; (* Some binary operations have a special notation depending on the backend *) (match (!backend, binop) with @@ -392,8 +394,8 @@ let extract_arrow (fmt : F.formatter) () : unit = if !Config.backend = Lean then F.pp_print_string fmt "→" else F.pp_print_string fmt "->" -let extract_const_generic (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (cg : const_generic) : unit = +let extract_const_generic (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (cg : const_generic) : unit = match cg with | CgGlobal id -> let s = ctx_get_global meta id ctx in @@ -496,7 +498,9 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) | HOL4 -> let { types; const_generics; trait_refs } = generics in (* Const generics are not supported in HOL4 *) - cassert (const_generics = []) meta "Constant generics are not supported yet when generating code for HOL4"; + cassert (const_generics = []) meta + "Constant generics are not supported yet when generating code \ + for HOL4"; let print_tys = match type_id with | TAdtId id -> not (TypeDeclId.Set.mem id no_params_tys) @@ -533,8 +537,8 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) if !parameterize_trait_types then craise meta "Unimplemented" else let type_name = - ctx_get_trait_type meta trait_ref.trait_decl_ref.trait_decl_id type_name - ctx + ctx_get_trait_type meta trait_ref.trait_decl_ref.trait_decl_id + type_name ctx in let add_brackets (s : string) = if !backend = Coq then "(" ^ s ^ ")" else s @@ -548,18 +552,22 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) *) match trait_ref.trait_id with | Self -> - cassert (trait_ref.generics = empty_generic_args) meta "TODO: Error message"; + cassert + (trait_ref.generics = empty_generic_args) + meta "TODO: Error message"; extract_trait_instance_id_with_dot meta ctx fmt no_params_tys false trait_ref.trait_id; F.pp_print_string fmt type_name | _ -> (* HOL4 doesn't have 1st class types *) - cassert (!backend <> HOL4) meta "Trait types are not supported yet when generating code for HOL4"; + cassert (!backend <> HOL4) meta + "Trait types are not supported yet when generating code for HOL4"; extract_trait_ref meta ctx fmt no_params_tys false trait_ref; F.pp_print_string fmt ("." ^ add_brackets type_name)) -and extract_trait_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = +and extract_trait_ref (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) + (tr : trait_ref) : unit = let use_brackets = tr.generics <> empty_generic_args && inside in if use_brackets then F.pp_print_string fmt "("; (* We may need to filter the parameters if the trait is builtin *) @@ -583,9 +591,9 @@ and extract_trait_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatt extract_generic_args meta ctx fmt no_params_tys generics; if use_brackets then F.pp_print_string fmt ")" -and extract_trait_decl_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_decl_ref) : - unit = +and extract_trait_decl_ref (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) + (tr : trait_decl_ref) : unit = let use_brackets = tr.decl_generics <> empty_generic_args && inside in let name = ctx_get_trait_decl meta tr.trait_decl_id ctx in if use_brackets then F.pp_print_string fmt "("; @@ -596,8 +604,9 @@ and extract_trait_decl_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo extract_generic_args meta ctx fmt no_params_tys generics; if use_brackets then F.pp_print_string fmt ")" -and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (generics : generic_args) : unit = +and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) + (generics : generic_args) : unit = let { types; const_generics; trait_refs } = generics in if !backend <> HOL4 then ( if types <> [] then ( @@ -606,7 +615,8 @@ and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.form (extract_ty meta ctx fmt no_params_tys true) types); if const_generics <> [] then ( - cassert (!backend <> HOL4) meta "Constant generics are not supported yet when generating code for HOL4"; + cassert (!backend <> HOL4) meta + "Constant generics are not supported yet when generating code for HOL4"; F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) (extract_const_generic meta ctx fmt true) @@ -653,9 +663,9 @@ and extract_trait_instance_id_with_dot (meta : Meta.meta) (ctx : extraction_ctx) extract_trait_instance_id meta ctx fmt no_params_tys inside id; F.pp_print_string fmt "." -and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) - : unit = +and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) + (id : trait_instance_id) : unit = let add_brackets (s : string) = if !backend = Coq then "(" ^ s ^ ")" else s in match id with | Self -> @@ -676,7 +686,9 @@ and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F F.pp_print_string fmt (add_brackets name) | ItemClause (inst_id, decl_id, item_name, clause_id) -> (* Use the trait decl id to lookup the name *) - let name = ctx_get_trait_item_clause meta decl_id item_name clause_id ctx in + let name = + ctx_get_trait_item_clause meta decl_id item_name clause_id ctx + in extract_trait_instance_id_with_dot meta ctx fmt no_params_tys true inst_id; F.pp_print_string fmt (add_brackets name) | TraitRef trait_ref -> @@ -760,10 +772,8 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : in (field_names, cons_name) | Some info -> - craise - def.meta - ("Invalid builtin information: " - ^ show_builtin_type_info info) + craise def.meta + ("Invalid builtin information: " ^ show_builtin_type_info info) in (* Add the fields *) let ctx = @@ -822,10 +832,10 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : ctx (** Print the variants *) -let extract_type_decl_variant (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (type_name : string) - (type_params : string list) (cg_params : string list) (cons_name : string) - (fields : field list) : unit = +let extract_type_decl_variant (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (type_decl_group : TypeDeclId.Set.t) + (type_name : string) (type_params : string list) (cg_params : string list) + (cons_name : string) (fields : field list) : unit = F.pp_print_space fmt (); (* variant box *) F.pp_open_hvbox fmt ctx.indent_incr; @@ -932,18 +942,20 @@ let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) let print_variant _variant_id (v : variant) = (* We don't lookup the name, because it may have a prefix for the type id (in the case of Lean) *) - let cons_name = ctx_compute_variant_name def.meta ctx def.llbc_name v.variant_name in + let cons_name = + ctx_compute_variant_name def.meta ctx def.llbc_name v.variant_name + in let fields = v.fields in - extract_type_decl_variant def.meta ctx fmt type_decl_group def_name type_params - cg_params cons_name fields + extract_type_decl_variant def.meta ctx fmt type_decl_group def_name + type_params cg_params cons_name fields in (* Print the variants *) let variants = VariantId.mapi (fun vid v -> (vid, v)) variants in List.iter (fun (vid, v) -> print_variant vid v) variants (** Extract a struct as a tuple *) -let extract_type_decl_tuple_struct_body (meta : Meta.meta) (ctx : extraction_ctx) - (fmt : F.formatter) (fields : field list) : unit = +let extract_type_decl_tuple_struct_body (meta : Meta.meta) + (ctx : extraction_ctx) (fmt : F.formatter) (fields : field list) : unit = (* If the type is empty, we need to have a special treatment *) if fields = [] then ( F.pp_print_space fmt (); @@ -1046,7 +1058,9 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) | Lean -> F.pp_open_vbox fmt 0); (* Print the fields *) let print_field (field_id : FieldId.id) (f : field) : unit = - let field_name = ctx_get_field def.meta (TAdtId def.def_id) field_id ctx in + let field_name = + ctx_get_field def.meta (TAdtId def.def_id) field_id ctx + in (* Open a box for the field *) F.pp_open_box fmt ctx.indent_incr; F.pp_print_string fmt field_name; @@ -1075,17 +1089,21 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) else ( (* We extract for Coq or Lean, and we have a recursive record, or a record in a group of mutually recursive types: we extract it as an inductive type *) - cassert (is_rec && (!backend = Coq || !backend = Lean)) def.meta "Constant generics are not supported yet when generating code for HOL4"; + cassert + (is_rec && (!backend = Coq || !backend = Lean)) + def.meta + "Constant generics are not supported yet when generating code for HOL4"; (* Small trick: in Lean we use namespaces, meaning we don't need to prefix the constructor name with the name of the type at definition site, i.e., instead of generating `inductive Foo := | MkFoo ...` like in Coq we generate `inductive Foo := | mk ... *) let cons_name = - if !backend = Lean then "mk" else ctx_get_struct def.meta (TAdtId def.def_id) ctx + if !backend = Lean then "mk" + else ctx_get_struct def.meta (TAdtId def.def_id) ctx in let def_name = ctx_get_local_type def.meta def.def_id ctx in - extract_type_decl_variant def.meta ctx fmt type_decl_group def_name type_params - cg_params cons_name fields) + extract_type_decl_variant def.meta ctx fmt type_decl_group def_name + type_params cg_params cons_name fields) in () @@ -1129,12 +1147,14 @@ let extract_comment_with_span (ctx : extraction_ctx) (fmt : F.formatter) in extract_comment fmt (sl @ [ span ] @ name) -let extract_trait_clause_type (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = +let extract_trait_clause_type (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) + (clause : trait_clause) : unit = let trait_name = ctx_get_trait_decl meta clause.trait_id ctx in F.pp_print_string fmt trait_name; (* let meta = (TraitDeclId.Map.find clause.trait_id ctx.trans_trait_decls).meta in - *)extract_generic_args meta ctx fmt no_params_tys clause.generics + *) + extract_generic_args meta ctx fmt no_params_tys clause.generics (** Insert a space, if necessary *) let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = @@ -1167,8 +1187,8 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) - [trait_decl]: if [Some], it means we are extracting the generics for a provided method and need to insert a trait self clause (see {!TraitSelfClauseId}). *) -let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) +let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) ?(use_forall_use_sep = true) ?(use_arrows = false) ?(as_implicits : bool = false) ?(space : bool ref option = None) ?(trait_decl : trait_decl option = None) (generics : generic_params) @@ -1176,7 +1196,9 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* HOL4 doesn't support const generics *) - cassert (cg_params = [] || !backend <> HOL4) meta "Constant generics are not supported yet when generating code for HOL4"; + cassert + (cg_params = [] || !backend <> HOL4) + meta "Constant generics are not supported yet when generating code for HOL4"; let left_bracket (implicit : bool) = if implicit && !backend <> FStar then F.pp_print_string fmt "{" else F.pp_print_string fmt "(" @@ -1304,7 +1326,8 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo ctx_get_const_generic_var trait_decl.meta cg.index ctx) dcgs; map - (fun c -> ctx_get_local_trait_clause trait_decl.meta c.clause_id ctx) + (fun c -> + ctx_get_local_trait_clause trait_decl.meta c.clause_id ctx) dtrait_clauses; ] in @@ -1355,7 +1378,8 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx_body, type_params, cg_params, trait_clauses = - ctx_add_generic_params def.meta def.llbc_name def.llbc_generics def.generics ctx + ctx_add_generic_params def.meta def.llbc_name def.llbc_generics def.generics + ctx in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then @@ -1394,10 +1418,14 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) | None -> F.pp_print_string fmt def_name); (* HOL4 doesn't support const generics, and type definitions in HOL4 don't support trait clauses *) - cassert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4) def.meta "Constant generics and type definitions with trait clauses are not supported yet when generating code for HOL4"; + cassert + ((cg_params = [] && trait_clauses = []) || !backend <> HOL4) + def.meta + "Constant generics and type definitions with trait clauses are not \ + supported yet when generating code for HOL4"; (* Print the generic parameters *) - extract_generic_params def.meta ctx_body fmt type_decl_group ~use_forall def.generics - type_params cg_params trait_clauses; + extract_generic_params def.meta ctx_body fmt type_decl_group ~use_forall + def.generics type_params cg_params trait_clauses; (* Print the "=" if we extract the body*) if extract_body then ( F.pp_print_space fmt (); @@ -1463,9 +1491,16 @@ let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (* Retrieve the definition name *) let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Generic parameters are unsupported *) - cassert (def.generics.const_generics = []) def.meta "Constant generics are not supported yet when generating code for HOL4"; + cassert + (def.generics.const_generics = []) + def.meta + "Constant generics are not supported yet when generating code for HOL4"; (* Trait clauses on type definitions are unsupported *) - cassert (def.generics.trait_clauses = []) def.meta "Types with trait clauses are not supported yet when generating code for HOL4"; + cassert + (def.generics.trait_clauses = []) + def.meta + "Types with trait clauses are not supported yet when generating code for \ + HOL4"; (* Types *) (* Count the number of parameters *) let num_params = List.length def.generics.types in @@ -1595,7 +1630,9 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (* Generate the instructions *) VariantId.iteri (fun vid (_ : variant) -> - let cons_name = ctx_get_variant decl.meta (TAdtId decl.def_id) vid ctx in + let cons_name = + ctx_get_variant decl.meta (TAdtId decl.def_id) vid ctx + in extract_coq_arguments_instruction ctx fmt cons_name num_params) variants; (* Add breaks to insert new lines between definitions *) @@ -1619,8 +1656,8 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) if is_rec then (* Add the type params *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics decl.generics - ctx + ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics + decl.generics ctx in let ctx, record_var = ctx_add_var decl.meta "x" (VarId.of_int 0) ctx in let ctx, field_var = ctx_add_var decl.meta "x" (VarId.of_int 1) ctx in @@ -1636,12 +1673,14 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) F.pp_open_hovbox fmt ctx.indent_incr; F.pp_print_string fmt "Definition"; F.pp_print_space fmt (); - let field_name = ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx in + let field_name = + ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx + in F.pp_print_string fmt field_name; (* Print the generics *) let as_implicits = true in - extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty ~as_implicits - decl.generics type_params cg_params trait_clauses; + extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty + ~as_implicits decl.generics type_params cg_params trait_clauses; (* Print the record parameter *) F.pp_print_space fmt (); F.pp_print_string fmt "("; @@ -1716,10 +1755,14 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) F.pp_open_hvbox fmt 0; (* Inner box for the projector definition *) F.pp_open_hovbox fmt ctx.indent_incr; - let ctx, record_var = ctx_add_var decl.meta "x" (VarId.of_int 0) ctx in + let ctx, record_var = + ctx_add_var decl.meta "x" (VarId.of_int 0) ctx + in F.pp_print_string fmt "Notation"; F.pp_print_space fmt (); - let field_name = ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx in + let field_name = + ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx + in F.pp_print_string fmt ("\"" ^ record_var ^ " .(" ^ field_name ^ ")\""); F.pp_print_space fmt (); F.pp_print_string fmt ":="; diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 9ca35e79..f85f9d1e 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -167,8 +167,15 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) (* We need to know if the declaration group contains a global - note that * groups containing globals contain exactly one declaration *) let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in - cassert ((not is_global_decl_body) || List.length d = 1) (List.hd d).meta "This global definition is in a group of mutually recursive definitions"; - cassert ((not !group_has_builtin_info) || List.length d = 1) (List.hd d).meta "This builtin function belongs to a group of mutually recursive definitions"; + cassert + ((not is_global_decl_body) || List.length d = 1) + (List.hd d).meta + "This global definition is in a group of mutually recursive definitions"; + cassert + ((not !group_has_builtin_info) || List.length d = 1) + (List.hd d).meta + "This builtin function belongs to a group of mutually recursive \ + definitions"; (* We ignore on purpose functions that cannot fail and consider they *can* * fail: the result of the analysis is not used yet to adjust the translation * so that the functions which syntactically can't fail don't use an error monad. diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 034304c7..453ad088 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -49,7 +49,8 @@ let compute_contexts (m : crate) : decls_ctx = to compute a normalization map (for the associated types) and that we added it in the context. *) -let normalize_inst_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : inst_fun_sig) : inst_fun_sig = +let normalize_inst_fun_sig (meta : Meta.meta) (ctx : eval_ctx) + (sg : inst_fun_sig) : inst_fun_sig = let { regions_hierarchy = _; trait_type_constraints = _; inputs; output } = sg in @@ -68,8 +69,8 @@ let normalize_inst_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : inst_fun_si clauses (we are not considering a function call, so we don't need to normalize because a trait clause was instantiated with a specific trait ref). *) -let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : fun_sig) - (regions_hierarchy : region_var_groups) (kind : item_kind) : +let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) + (sg : fun_sig) (regions_hierarchy : region_var_groups) (kind : item_kind) : eval_ctx * inst_fun_sig = let tr_self = match kind with @@ -150,7 +151,9 @@ let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : fun_s in { regions; types; const_generics; trait_refs } in - let inst_sg = instantiate_fun_sig meta ctx generics tr_self sg regions_hierarchy in + let inst_sg = + instantiate_fun_sig meta ctx generics tr_self sg regions_hierarchy + in (* Compute the normalization maps *) let ctx = AssociatedTypes.ctx_add_norm_trait_types_from_preds meta ctx @@ -203,7 +206,8 @@ let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : at the same time the normalization map for the associated types. *) let ctx, inst_sg = - symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy fdef.kind + symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy + fdef.kind in (* Create fresh symbolic values for the inputs *) let input_svs = @@ -236,7 +240,9 @@ let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : let ctx = ctx_push_uninitialized_var fdef.meta ctx ret_var in (* Push the input variables (initialized with symbolic values) *) let input_values = List.map mk_typed_value_from_symbolic_value input_svs in - let ctx = ctx_push_vars fdef.meta ctx (List.combine input_vars input_values) in + let ctx = + ctx_push_vars fdef.meta ctx (List.combine input_vars input_values) + in (* Push the remaining local variables (initialized with ⊥) *) let ctx = ctx_push_uninitialized_vars fdef.meta ctx local_vars in (* Return *) @@ -281,7 +287,8 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies in let _, ret_inst_sg = - symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy fdef.kind + symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy + fdef.kind in let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) @@ -417,9 +424,10 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) | Loop (loop_id', rg_id', LoopSynthInput) -> (* We only allow to end the loop synth input abs for the region group [rg_id] *) - sanity_check ( - if Option.is_some loop_id then loop_id = Some loop_id' - else true) fdef.meta; + sanity_check + (if Option.is_some loop_id then loop_id = Some loop_id' + else true) + fdef.meta; (* Loop abstractions *) let rg_id' = Option.get rg_id' in if rg_id' = back_id && inside_loop then @@ -597,8 +605,8 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) * the executions can lead to a panic *) if synthesize then Some SA.Panic else None | Unit | Break _ | Continue _ -> - craise - fdef.meta ("evaluate_function_symbolic failed on: " ^ name_to_string ()) + craise fdef.meta + ("evaluate_function_symbolic failed on: " ^ name_to_string ()) in (* Evaluate the function *) @@ -646,12 +654,11 @@ module Test = struct let pop_return_value = true in pop_frame config fdef.meta pop_return_value (fun _ _ -> None) ctx | _ -> - craise - fdef.meta - ("Unit test failed (concrete execution) on: " - ^ Print.Types.name_to_string - (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) - fdef.name) + craise fdef.meta + ("Unit test failed (concrete execution) on: " + ^ Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) + fdef.name) in (* Evaluate the function *) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index c1cf8441..2ccf2d5d 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -30,8 +30,9 @@ let log = Logging.borrows_log loans. This is used to merge borrows with abstractions, to compute loop fixed points for instance. *) -let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id option) - (allow_inner_loans : bool) (l : BorrowId.id) (ctx : eval_ctx) : +let end_borrow_get_borrow (meta : Meta.meta) + (allowed_abs : AbstractionId.id option) (allow_inner_loans : bool) + (l : BorrowId.id) (ctx : eval_ctx) : ( eval_ctx * (AbstractionId.id option * g_borrow_content) option, priority_borrows_or_abs ) result = @@ -245,17 +246,23 @@ let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id opt give the value back. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv : typed_value) - (ctx : eval_ctx) : eval_ctx = +let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) + (nv : typed_value) (ctx : eval_ctx) : eval_ctx = (* Sanity check *) - exec_assert (not (loans_in_value nv)) meta "Can not end a borrow because the value to give back contains bottom"; - exec_assert (not (bottom_in_value ctx.ended_regions nv)) meta "Can not end a borrow because the value to give back contains bottom"; + exec_assert + (not (loans_in_value nv)) + meta "Can not end a borrow because the value to give back contains bottom"; + exec_assert + (not (bottom_in_value ctx.ended_regions nv)) + meta "Can not end a borrow because the value to give back contains bottom"; (* Debug *) log#ldebug (lazy ("give_back_value:\n- bid: " ^ BorrowId.to_string bid ^ "\n- value: " ^ typed_value_to_string ~meta:(Some meta) ctx nv - ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n- context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -382,8 +389,8 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv let given_back_meta = nv in (* Apply the projection *) let given_back = - apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions nv borrowed_value_aty + apply_proj_borrows meta check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions nv borrowed_value_aty in (* Continue giving back in the child value *) let child = super#visit_typed_avalue opt_abs child in @@ -409,8 +416,8 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv * we don't register the fact that we inserted the value somewhere * (i.e., we don't call {!set_replaced}) *) let given_back = - apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions nv borrowed_value_aty + apply_proj_borrows meta check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions nv borrowed_value_aty in (* Continue giving back in the child value *) let child = super#visit_typed_avalue opt_abs child in @@ -440,9 +447,9 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv apply_registered_reborrows ctx (** Give back a *modified* symbolic value. *) -let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions : RegionId.Set.t) - (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) - (ctx : eval_ctx) : eval_ctx = +let give_back_symbolic_value (_config : config) (meta : Meta.meta) + (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) + (nsv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) sanity_check (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) meta; (* Store the given-back value as a meta-value for synthesis purposes *) @@ -485,8 +492,9 @@ let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions end abstraction when ending this abstraction. When doing this, we need to convert the {!avalue} to a {!type:value} by introducing the proper symbolic values. *) -let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) (bid : BorrowId.id) - (nv : typed_avalue) (nsv : typed_value) (ctx : eval_ctx) : eval_ctx = +let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) + (bid : BorrowId.id) (nv : typed_avalue) (nsv : typed_value) (ctx : eval_ctx) + : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -588,7 +596,8 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) ( we update. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = +let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) + (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -666,8 +675,8 @@ let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (ctx : eval_ to an environment by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (new_bid : BorrowId.id) - (ctx : eval_ctx) : eval_ctx = +let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) + (new_bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = (* Keep track of changes *) let r = ref false in let set_ref () = @@ -720,7 +729,8 @@ let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (new_bid : B be expanded (because expanding this symbolic value would require expanding a reference whose region has already ended). *) -let convert_avalue_to_given_back_value (meta : Meta.meta) (av : typed_avalue) : symbolic_value = +let convert_avalue_to_given_back_value (meta : Meta.meta) (av : typed_avalue) : + symbolic_value = mk_fresh_symbolic_value meta av.ty (** Auxiliary function: see {!end_borrow_aux}. @@ -739,8 +749,8 @@ let convert_avalue_to_given_back_value (meta : Meta.meta) (av : typed_avalue) : borrows. This kind of internal reshuffling. should be similar to ending abstractions (it is tantamount to ending *sub*-abstractions). *) -let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_borrow_content) - (ctx : eval_ctx) : eval_ctx = +let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) + (bc : g_borrow_content) (ctx : eval_ctx) : eval_ctx = (* Debug *) log#ldebug (lazy @@ -750,7 +760,9 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_bor | Abstract bc -> aborrow_content_to_string ~meta:(Some meta) ctx bc in "give_back:\n- bid: " ^ BorrowId.to_string l ^ "\n- content: " ^ bc - ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n- context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* This is used for sanity checks *) let sanity_ek = { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } @@ -803,8 +815,8 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_bor | AEndedSharedBorrow ) -> craise meta "Unreachable" -let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowId.id) - (ctx0 : eval_ctx) : cm_fun = +let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) + (l : BorrowId.id) (ctx0 : eval_ctx) : cm_fun = let check_disappeared (ctx : eval_ctx) : unit = let _ = match lookup_borrow_opt ek_all l ctx with @@ -814,8 +826,9 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI (lazy (fun_name ^ ": " ^ BorrowId.to_string l ^ ": borrow didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); craise meta "Borrow not eliminated" in match lookup_loan_opt meta ek_all l ctx with @@ -825,8 +838,9 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI (lazy (fun_name ^ ": " ^ BorrowId.to_string l ^ ": loan didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); craise meta "Loan not eliminated" in unit_to_cm_fun check_disappeared @@ -852,8 +866,9 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI perform anything smart and is trusted, and another function for the book-keeping. *) -let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (allowed_abs : AbstractionId.id option) (l : BorrowId.id) : cm_fun = +let rec end_borrow_aux (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (allowed_abs : AbstractionId.id option) + (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) let chain0 = chain in @@ -863,7 +878,7 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_a log#ldebug (lazy ("end borrow: " ^ BorrowId.to_string l ^ ":\n- original context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Utility function for the sanity checks: check that the borrow disappeared * from the context *) @@ -942,8 +957,9 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_a (* Compose *) cc cf ctx -and end_borrows_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (allowed_abs : AbstractionId.id option) (lset : BorrowId.Set.t) : cm_fun = +and end_borrows_aux (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (allowed_abs : AbstractionId.id option) + (lset : BorrowId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the borrow ids, * so that we actually end from the smallest id to the highest id - just @@ -953,12 +969,13 @@ and end_borrows_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ (fun cf id -> end_borrow_aux config meta chain allowed_abs id cf) cf ids -and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_id : AbstractionId.id) : cm_fun = +and end_abstraction_aux (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) let chain = - add_borrow_or_abs_id_to_chain meta "end_abstraction_aux: " (AbsId abs_id) chain + add_borrow_or_abs_id_to_chain meta "end_abstraction_aux: " (AbsId abs_id) + chain in (* Remember the original context for printing purposes *) let ctx0 = ctx in @@ -966,7 +983,8 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0)); + ^ "\n- original context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0)); (* Lookup the abstraction - note that if we end a list of abstractions, ending one abstraction may lead to the current abstraction having @@ -984,11 +1002,10 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (* Check that we can end the abstraction *) if abs.can_end then () else - craise - meta - ("Can't end abstraction " - ^ AbstractionId.to_string abs.abs_id - ^ " as it is set as non-endable"); + craise meta + ("Can't end abstraction " + ^ AbstractionId.to_string abs.abs_id + ^ " as it is set as non-endable"); (* End the parent abstractions first *) let cc = end_abstractions_aux config meta chain abs.parents in @@ -1010,7 +1027,8 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx))) + ^ "\n- context after loans ended:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* End the abstraction itself by redistributing the borrows it contains *) @@ -1030,7 +1048,9 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (* Remove all the references to the id of the current abstraction, and remove * the abstraction itself. * **Rk.**: this is where we synthesize the updated symbolic AST *) - let cc = comp cc (end_abstraction_remove_from_context config meta abs_id) in + let cc = + comp cc (end_abstraction_remove_from_context config meta abs_id) + in (* Debugging *) let cc = @@ -1039,8 +1059,10 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx))) + ^ "\n- original context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* Sanity check: ending an abstraction must preserve the invariants *) @@ -1052,8 +1074,8 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (* Apply the continuation *) cc cf ctx -and end_abstractions_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_ids : AbstractionId.Set.t) : cm_fun = +and end_abstractions_aux (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_ids : AbstractionId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the abstraction ids, * so that we actually end from the smallest id to the highest id - just @@ -1063,8 +1085,8 @@ and end_abstractions_aux (config : config) (meta : Meta.meta) (chain : borrow_or (fun cf id -> end_abstraction_aux config meta chain id cf) cf abs_ids -and end_abstraction_loans (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_id : AbstractionId.id) : cm_fun = +and end_abstraction_loans (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Lookup the abstraction *) let abs = ctx_lookup_abs ctx abs_id in @@ -1091,14 +1113,16 @@ and end_abstraction_loans (config : config) (meta : Meta.meta) (chain : borrow_o | Some (SymbolicValue sv) -> (* There is a proj_loans over a symbolic value: end the proj_borrows * which intersect this proj_loans, then end the proj_loans itself *) - let cc = end_proj_loans_symbolic config meta chain abs_id abs.regions sv in + let cc = + end_proj_loans_symbolic config meta chain abs_id abs.regions sv + in (* Reexplore, looking for loans *) let cc = comp cc (end_abstraction_loans config meta chain abs_id) in (* Continue *) cc cf ctx -and end_abstraction_borrows (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_id : AbstractionId.id) : cm_fun = +and end_abstraction_borrows (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -1297,9 +1321,9 @@ and end_abstraction_remove_from_context (_config : config) (meta : Meta.meta) intersecting proj_borrows, either in the concrete context or in an abstraction *) -and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_id : AbstractionId.id) (regions : RegionId.Set.t) (sv : symbolic_value) - : cm_fun = +and end_proj_loans_symbolic (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) + (regions : RegionId.Set.t) (sv : symbolic_value) : cm_fun = fun cf ctx -> (* Small helpers for sanity checks *) let check ctx = no_aproj_over_symbolic_in_context meta sv ctx in @@ -1310,7 +1334,9 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow in (* Find the first proj_borrows which intersects the proj_loans *) let explore_shared = true in - match lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx with + match + lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx + with | None -> (* We couldn't find any in the context: it means that the symbolic value * is in the concrete environment (or that we dropped it, in which case @@ -1366,7 +1392,9 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow let cf_end_internal : cm_fun = fun cf ctx -> (* All the proj_borrows are owned: simply erase them *) - let ctx = remove_intersecting_aproj_borrows_shared meta regions sv ctx in + let ctx = + remove_intersecting_aproj_borrows_shared meta regions sv ctx + in (* End the loan itself *) let ctx = update_aproj_loans_to_ended meta abs_id sv ctx in (* Sanity check *) @@ -1402,9 +1430,11 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow * replace it with... Maybe we should introduce an ABottomProj? *) let ctx = update_aproj_borrows meta abs_id sv AIgnoredProjBorrows ctx in (* Sanity check: no other occurrence of an intersecting projector of borrows *) - sanity_check ( - Option.is_none - (lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx)) meta ; + sanity_check + (Option.is_none + (lookup_intersecting_aproj_borrows_opt meta explore_shared regions + sv ctx)) + meta; (* End the projector of loans *) let ctx = update_aproj_loans_to_ended meta abs_id sv ctx in (* Sanity check *) @@ -1423,9 +1453,10 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow (* Continue *) cc cf ctx -let end_borrow config (meta : Meta.meta ) : BorrowId.id -> cm_fun = end_borrow_aux config meta [] None +let end_borrow config (meta : Meta.meta) : BorrowId.id -> cm_fun = + end_borrow_aux config meta [] None -let end_borrows config (meta : Meta.meta ) : BorrowId.Set.t -> cm_fun = +let end_borrows config (meta : Meta.meta) : BorrowId.Set.t -> cm_fun = end_borrows_aux config meta [] None let end_abstraction config meta = end_abstraction_aux config meta [] @@ -1466,7 +1497,9 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) log#ldebug (lazy ("promote_shared_loan_to_mut_loan:\n- loan: " ^ BorrowId.to_string l - ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n- context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* Lookup the shared loan - note that we can't promote a shared loan * in a shared value, but we can do it in a mutably borrowed value. * This is important because we can do: [let y = &two-phase ( *x );] @@ -1479,15 +1512,21 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) craise meta "Expected a shared loan, found a mut loan" | _, Concrete (VSharedLoan (bids, sv)) -> (* Check that there is only one borrow id (l) and update the loan *) - cassert (BorrowId.Set.mem l bids && BorrowId.Set.cardinal bids = 1) meta "There should only be one borrow id"; + cassert + (BorrowId.Set.mem l bids && BorrowId.Set.cardinal bids = 1) + meta "There should only be one borrow id"; (* We need to check that there aren't any loans in the value: we should have gotten rid of those already, but it is better to do a sanity check. *) sanity_check (not (loans_in_value sv)) meta; (* Check there isn't {!Bottom} (this is actually an invariant *) - cassert (not (bottom_in_value ctx.ended_regions sv)) meta "There shouldn't be a bottom"; + cassert + (not (bottom_in_value ctx.ended_regions sv)) + meta "There shouldn't be a bottom"; (* Check there aren't reserved borrows *) - cassert (not (reserved_in_value sv)) meta "There shouldn't be reserved borrows"; + cassert + (not (reserved_in_value sv)) + meta "There shouldn't be reserved borrows"; (* Update the loan content *) let ctx = update_loan meta ek l (VMutLoan l) ctx in (* Continue *) @@ -1495,18 +1534,17 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) | _, Abstract _ -> (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) - craise - meta - "Can't promote a shared loan to a mutable loan if the loan is \ - inside an abstraction" + craise meta + "Can't promote a shared loan to a mutable loan if the loan is inside \ + an abstraction" (** Helper function: see {!activate_reserved_mut_borrow}. This function updates a shared borrow to a mutable borrow (and that is all: it doesn't touch the corresponding loan). *) -let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) (cf : m_fun) - (borrowed_value : typed_value) : m_fun = +let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) + (cf : m_fun) (borrowed_value : typed_value) : m_fun = fun ctx -> (* Lookup the reserved borrow - note that we don't go inside borrows/loans: there can't be reserved borrows inside other borrows/loans @@ -1523,17 +1561,16 @@ let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) update_borrow meta ek l (VMutBorrow (l, borrowed_value)) ctx | Abstract _ -> (* This can't happen for sure *) - craise - meta - "Can't promote a shared borrow to a mutable borrow if the borrow \ - is inside an abstraction" + craise meta + "Can't promote a shared borrow to a mutable borrow if the borrow is \ + inside an abstraction" in (* Continue *) cf ctx (** Promote a reserved mut borrow to a mut borrow. *) -let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) (l : BorrowId.id) : cm_fun - = +let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) + (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Lookup the value *) let ek = @@ -1588,10 +1625,9 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) (l : Bo | _, Abstract _ -> (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) - craise - meta - "Can't activate a reserved mutable borrow referencing a loan inside\n\ - \ an abstraction" + craise meta + "Can't activate a reserved mutable borrow referencing a loan inside\n\ + \ an abstraction" let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (destructure_shared_values : bool) (ctx : eval_ctx) (abs0 : abs) : abs = @@ -1621,7 +1657,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) match lc with | ASharedLoan (bids, sv, child_av) -> (* We don't support nested borrows for now *) - cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; + cassert + (not (value_has_borrows ctx sv.value)) + meta "Nested borrows are not supported yet"; (* Destructure the shared value *) let avl, sv = if destructure_shared_values then list_values sv else ([], sv) @@ -1648,7 +1686,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) push { value; ty } | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert + (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) + meta "Nested borrows are not supported yet"; sanity_check (opt_bid = None) meta; (* Simply explore the child *) list_avalues false push_fail child_av @@ -1659,7 +1699,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) { child = child_av; given_back = _; given_back_meta = _ } | AIgnoredSharedLoan child_av -> (* We don't support nested borrows for now *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert + (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) + meta "Nested borrows are not supported yet"; (* Simply explore the child *) list_avalues false push_fail child_av) | ABorrow bc -> ( @@ -1679,14 +1721,18 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) push av | AIgnoredMutBorrow (opt_bid, child_av) -> (* We don't support nested borrows for now *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert + (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) + meta "Nested borrows are not supported yet"; sanity_check (opt_bid = None) meta; (* Just explore the child *) list_avalues false push_fail child_av | AEndedIgnoredMutBorrow { child = child_av; given_back = _; given_back_meta = _ } -> (* We don't support nested borrows for now *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert + (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) + meta "Nested borrows are not supported yet"; (* Just explore the child *) list_avalues false push_fail child_av | AProjSharedBorrow asb -> @@ -1725,9 +1771,12 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) let avl, sv = list_values sv in if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) - cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ty) meta + "Nested borrows are not supported yet"; let av : typed_avalue = - sanity_check (not (value_has_loans_or_borrows ctx sv.value)) meta; + sanity_check + (not (value_has_loans_or_borrows ctx sv.value)) + meta; (* We introduce fresh ids for the symbolic values *) let mk_value_with_fresh_sids (v : typed_value) : typed_value = let visitor = @@ -1742,7 +1791,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) in let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) - let value = ALoan (ASharedLoan (bids, sv, mk_aignored meta ty)) in + let value = + ALoan (ASharedLoan (bids, sv, mk_aignored meta ty)) + in { value; ty } in let avl = List.append [ av ] avl in @@ -1762,16 +1813,16 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (* Update *) { abs0 with avalues; kind = abs_kind; can_end } -let abs_is_destructured (meta : Meta.meta) (destructure_shared_values : bool) (ctx : eval_ctx) - (abs : abs) : bool = +let abs_is_destructured (meta : Meta.meta) (destructure_shared_values : bool) + (ctx : eval_ctx) (abs : abs) : bool = let abs' = destructure_abs meta abs.kind abs.can_end destructure_shared_values ctx abs in abs = abs' -let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) - (destructure_shared_values : bool) (ctx : eval_ctx) (v : typed_value) : - abs list = +let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) + (can_end : bool) (destructure_shared_values : bool) (ctx : eval_ctx) + (v : typed_value) : abs list = (* Convert the value to a list of avalues *) let absl = ref [] in let push_abs (r_id : RegionId.id) (avalues : typed_avalue list) : unit = @@ -1852,20 +1903,24 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ (avl, { v with value = VAdt adt }) | VBorrow bc -> ( let _, ref_ty, kind = ty_as_ref ty in - cassert (ty_no_regions ref_ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ref_ty) meta + "Nested borrows are not supported yet"; (* Sanity check *) sanity_check allow_borrows meta; (* Convert the borrow content *) match bc with | VSharedBorrow bid -> - cassert (ty_no_regions ref_ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ref_ty) meta + "Nested borrows are not supported yet"; let ty = TRef (RFVar r_id, ref_ty, kind) in let value = ABorrow (ASharedBorrow bid) in ([ { value; ty } ], v) | VMutBorrow (bid, bv) -> let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) - cassert (not (value_has_borrows ctx bv.value)) meta "Nested borrows are not supported yet"; + cassert + (not (value_has_borrows ctx bv.value)) + meta "Nested borrows are not supported yet"; (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) let ty = TRef (RFVar r_id, ref_ty, kind) in let ignored = mk_aignored meta ref_ty in @@ -1884,10 +1939,13 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ | VSharedLoan (bids, sv) -> let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) - cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; + cassert + (not (value_has_borrows ctx sv.value)) + meta "Nested borrows are not supported yet"; (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ty) meta + "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RShared in let ignored = mk_aignored meta ty in (* Rem.: the shared value might contain loans *) @@ -1905,7 +1963,8 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ | VMutLoan bid -> (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ty) meta + "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RMut in let ignored = mk_aignored meta ty in let av = ALoan (AMutLoan (bid, ignored)) in @@ -1914,7 +1973,9 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ | VSymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - cassert (not (value_has_borrows ctx v.value)) meta "Nested borrows are not supported yet"; + cassert + (not (value_has_borrows ctx v.value)) + meta "Nested borrows are not supported yet"; (* Return nothing *) ([], v) in @@ -1955,8 +2016,8 @@ type merge_abstraction_info = { - all the borrows are destructured (for instance, shared loans can't contain shared loans). *) -let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) (abs : abs) : - merge_abstraction_info = +let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) + (abs : abs) : merge_abstraction_info = let loans : loan_id_set ref = ref BorrowId.Set.empty in let borrows : borrow_id_set ref = ref BorrowId.Set.empty in let borrows_loans : borrow_or_loan_id list ref = ref [] in @@ -2068,7 +2129,7 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) (abs : ab method! visit_symbolic_value _ sv = (* Sanity check: no borrows *) - sanity_check (not (symbolic_value_has_borrows ctx sv)) meta + sanity_check (not (symbolic_value_has_borrows ctx sv)) meta end in @@ -2135,19 +2196,25 @@ type merge_duplicates_funcs = { Merge two abstractions into one, without updating the context. *) -let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) - (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) (abs0 : abs) - (abs1 : abs) : abs = +let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) + (can_end : bool) (merge_funs : merge_duplicates_funcs option) + (ctx : eval_ctx) (abs0 : abs) (abs1 : abs) : abs = log#ldebug (lazy - ("merge_into_abstraction_aux:\n- abs0:\n" ^ abs_to_string meta ctx abs0 - ^ "\n\n- abs1:\n" ^ abs_to_string meta ctx abs1)); + ("merge_into_abstraction_aux:\n- abs0:\n" + ^ abs_to_string meta ctx abs0 + ^ "\n\n- abs1:\n" + ^ abs_to_string meta ctx abs1)); (* Check that the abstractions are destructured *) if !Config.sanity_checks then ( let destructure_shared_values = true in - sanity_check (abs_is_destructured meta destructure_shared_values ctx abs0) meta; - sanity_check (abs_is_destructured meta destructure_shared_values ctx abs1) meta); + sanity_check + (abs_is_destructured meta destructure_shared_values ctx abs0) + meta; + sanity_check + (abs_is_destructured meta destructure_shared_values ctx abs1) + meta); (* Compute the relevant information *) let { @@ -2172,9 +2239,10 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) - if merge_funs = None then ( - sanity_check (BorrowId.Set.disjoint borrows0 borrows1) meta; - sanity_check (BorrowId.Set.disjoint loans0 loans1)) meta; + if merge_funs = None then + (sanity_check (BorrowId.Set.disjoint borrows0 borrows1) meta; + sanity_check (BorrowId.Set.disjoint loans0 loans1)) + meta; (* Merge. There are several cases: @@ -2405,10 +2473,13 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end match lc with | ASharedLoan (bids, sv, child) -> let bids = filter_bids bids in - sanity_check (not (BorrowId.Set.is_empty bids)) meta; + sanity_check + (not (BorrowId.Set.is_empty bids)) + meta; sanity_check (is_aignored child.value) meta; - sanity_check ( - not (value_has_loans_or_borrows ctx sv.value)) meta; + sanity_check + (not (value_has_loans_or_borrows ctx sv.value)) + meta; let lc = ASharedLoan (bids, sv, child) in set_loans_as_merged bids; Some { value = ALoan lc; ty } @@ -2487,9 +2558,9 @@ let ctx_merge_regions (ctx : eval_ctx) (rid : RegionId.id) let env = Substitute.env_subst_rids rsubst ctx.env in { ctx with env } -let merge_into_abstraction (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) - (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) - (abs_id0 : AbstractionId.id) (abs_id1 : AbstractionId.id) : +let merge_into_abstraction (meta : Meta.meta) (abs_kind : abs_kind) + (can_end : bool) (merge_funs : merge_duplicates_funcs option) + (ctx : eval_ctx) (abs_id0 : AbstractionId.id) (abs_id1 : AbstractionId.id) : eval_ctx * AbstractionId.id = (* Lookup the abstractions *) let abs0 = ctx_lookup_abs ctx abs_id0 in diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index fbd2cd7a..30b75790 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -8,7 +8,8 @@ open Cps applies this change to an environment [ctx] by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -val reborrow_shared : Meta.meta -> BorrowId.id -> BorrowId.id -> eval_ctx -> eval_ctx +val reborrow_shared : + Meta.meta -> BorrowId.id -> BorrowId.id -> eval_ctx -> eval_ctx (** End a borrow identified by its id, while preserving the invariants. @@ -27,10 +28,12 @@ val end_abstraction : config -> Meta.meta -> AbstractionId.id -> cm_fun val end_abstractions : config -> Meta.meta -> AbstractionId.Set.t -> cm_fun (** End a borrow and return the resulting environment, ignoring synthesis *) -val end_borrow_no_synth : config -> Meta.meta -> BorrowId.id -> eval_ctx -> eval_ctx +val end_borrow_no_synth : + config -> Meta.meta -> BorrowId.id -> eval_ctx -> eval_ctx (** End a set of borrows and return the resulting environment, ignoring synthesis *) -val end_borrows_no_synth : config -> Meta.meta -> BorrowId.Set.t -> eval_ctx -> eval_ctx +val end_borrows_no_synth : + config -> Meta.meta -> BorrowId.Set.t -> eval_ctx -> eval_ctx (** End an abstraction and return the resulting environment, ignoring synthesis *) val end_abstraction_no_synth : @@ -91,7 +94,8 @@ val promote_reserved_mut_borrow : config -> Meta.meta -> BorrowId.id -> cm_fun - [ctx] - [abs] *) -val destructure_abs : Meta.meta -> abs_kind -> bool -> bool -> eval_ctx -> abs -> abs +val destructure_abs : + Meta.meta -> abs_kind -> bool -> bool -> eval_ctx -> abs -> abs (** Return [true] if the values in an abstraction are destructured. @@ -232,7 +236,7 @@ type merge_duplicates_funcs = { results from the merge. *) val merge_into_abstraction : - Meta.meta -> + Meta.meta -> abs_kind -> bool -> merge_duplicates_funcs option -> diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 1948c5a6..02ceffb4 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -72,13 +72,12 @@ let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = String.concat " -> " ids (** Add a borrow or abs id to a chain of ids, while checking that we don't loop *) -let add_borrow_or_abs_id_to_chain (meta : Meta.meta) (msg : string) (id : borrow_or_abs_id) - (ids : borrow_or_abs_ids) : borrow_or_abs_ids = +let add_borrow_or_abs_id_to_chain (meta : Meta.meta) (msg : string) + (id : borrow_or_abs_id) (ids : borrow_or_abs_ids) : borrow_or_abs_ids = if List.mem id ids then - craise - meta - (msg ^ "detected a loop in the chain of ids: " - ^ borrow_or_abs_ids_chain_to_string (id :: ids)) + craise meta + (msg ^ "detected a loop in the chain of ids: " + ^ borrow_or_abs_ids_chain_to_string (id :: ids)) else id :: ids (** Helper function. @@ -95,7 +94,8 @@ let add_borrow_or_abs_id_to_chain (meta : Meta.meta) (msg : string) (id : borrow TODO: is there a way of deriving such a comparison? TODO: rename *) -let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool -> bool) +let rec compare_rtys (meta : Meta.meta) (default : bool) + (combine : bool -> bool -> bool) (compare_regions : region -> region -> bool) (ty1 : rty) (ty2 : rty) : bool = let compare = compare_rtys meta default combine compare_regions in @@ -173,8 +173,8 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool Note that the two abstractions have different views (in terms of regions) of the symbolic value (hence the two region types). *) -let projections_intersect (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) - (rset2 : RegionId.Set.t) : bool = +let projections_intersect (meta : Meta.meta) (ty1 : rty) + (rset1 : RegionId.Set.t) (ty2 : rty) (rset2 : RegionId.Set.t) : bool = let default = false in let combine b1 b2 = b1 || b2 in let compare_regions r1 r2 = @@ -188,8 +188,8 @@ let projections_intersect (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t The regions in the types shouldn't be erased (this function will raise an exception otherwise). *) -let projection_contains (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) - (rset2 : RegionId.Set.t) : bool = +let projection_contains (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) + (ty2 : rty) (rset2 : RegionId.Set.t) : bool = let default = true in let combine b1 b2 = b1 && b2 in let compare_regions r1 r2 = @@ -205,8 +205,8 @@ let projection_contains (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) the {!InterpreterUtils.abs_or_var_id} is not necessarily {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.VarId} or {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.DummyVarId}: there can be concrete loans in abstractions (in the shared values). *) -let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : - (abs_or_var_id * g_loan_content) option = +let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (ctx : eval_ctx) : (abs_or_var_id * g_loan_content) option = (* We store here whether we are inside an abstraction or a value - note that we * could also track that with the environment, it would probably be more idiomatic * and cleaner *) @@ -301,8 +301,8 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) The loan is referred to by a borrow id. Raises an exception if no loan was found. *) -let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : - abs_or_var_id * g_loan_content = +let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (ctx : eval_ctx) : abs_or_var_id * g_loan_content = match lookup_loan_opt meta ek l ctx with | None -> craise meta "Unreachable" | Some res -> res @@ -313,8 +313,8 @@ let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ct This is a helper function: it might break invariants. *) -let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nlc : loan_content) - (ctx : eval_ctx) : eval_ctx = +let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (nlc : loan_content) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one loan: when updating * inside values, we check we don't update more than one loan. Then, upon * returning we check that we updated at least once. *) @@ -376,8 +376,8 @@ let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nl This is a helper function: it might break invariants. *) -let update_aloan (meta : Meta.meta ) (ek : exploration_kind) (l : BorrowId.id) (nlc : aloan_content) - (ctx : eval_ctx) : eval_ctx = +let update_aloan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (nlc : aloan_content) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one loan: when updating * inside values, we check we don't update more than one loan. Then, upon * returning we check that we updated at least once. *) @@ -482,8 +482,8 @@ let lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) Raise an exception if no loan was found *) -let lookup_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : - g_borrow_content = +let lookup_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (ctx : eval_ctx) : g_borrow_content = match lookup_borrow_opt ek l ctx with | None -> craise meta "Unreachable" | Some lc -> lc @@ -551,8 +551,8 @@ let update_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) This is a helper function: it might break invariants. *) -let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nv : avalue) - (ctx : eval_ctx) : eval_ctx = +let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (nv : avalue) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one borrow: when updating * inside values, we check we don't update more than one borrow. Then, upon * returning we check that we updated at least once. *) @@ -701,9 +701,9 @@ type looked_up_aproj_borrows = This is a helper function. *) -let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) (lookup_shared : bool) - (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : - looked_up_aproj_borrows option = +let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) + (lookup_shared : bool) (regions : RegionId.Set.t) (sv : symbolic_value) + (ctx : eval_ctx) : looked_up_aproj_borrows option = let found : looked_up_aproj_borrows option ref = ref None in let set_non_shared ((id, ty) : AbstractionId.id * rty) : unit = match !found with @@ -718,8 +718,7 @@ let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) (lookup_shared : bo in let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = if - proj_borrows_intersects_proj_loans - meta + proj_borrows_intersects_proj_loans meta (abs.regions, sv', proj_ty) (regions, sv) then @@ -774,10 +773,13 @@ let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) (lookup_shared : bo Returns the id of the owning abstraction, and the projection type used in this abstraction. *) -let lookup_intersecting_aproj_borrows_not_shared_opt (meta : Meta.meta) (regions : RegionId.Set.t) - (sv : symbolic_value) (ctx : eval_ctx) : (AbstractionId.id * rty) option = +let lookup_intersecting_aproj_borrows_not_shared_opt (meta : Meta.meta) + (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : + (AbstractionId.id * rty) option = let lookup_shared = false in - match lookup_intersecting_aproj_borrows_opt meta lookup_shared regions sv ctx with + match + lookup_intersecting_aproj_borrows_opt meta lookup_shared regions sv ctx + with | None -> None | Some (NonSharedProj (abs_id, rty)) -> Some (abs_id, rty) | _ -> craise meta "Unexpected" @@ -787,7 +789,8 @@ let lookup_intersecting_aproj_borrows_not_shared_opt (meta : Meta.meta) (regions This is a helper function: it might break invariants. *) -let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bool) +let update_intersecting_aproj_borrows (meta : Meta.meta) + (can_update_shared : bool) (update_shared : AbstractionId.id -> rty -> abstract_shared_borrows) (update_non_shared : AbstractionId.id -> rty -> aproj) (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx @@ -795,7 +798,9 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo (* Small helpers for sanity checks *) let shared = ref None in let add_shared () = - match !shared with None -> shared := Some true | Some b -> sanity_check b meta + match !shared with + | None -> shared := Some true + | Some b -> sanity_check b meta in let set_non_shared () = match !shared with @@ -804,8 +809,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo in let check_proj_borrows is_shared abs sv' proj_ty = if - proj_borrows_intersects_proj_loans - meta + proj_borrows_intersects_proj_loans meta (abs.regions, sv', proj_ty) (regions, sv) then ( @@ -821,7 +825,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo method! visit_abstract_shared_borrows abs asb = (* Sanity check *) - (match !shared with Some b -> sanity_check b meta | _ -> ()); + (match !shared with Some b -> sanity_check b meta | _ -> ()); (* Explore *) if can_update_shared then let abs = Option.get abs in @@ -864,8 +868,9 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo This is a helper function: it might break invariants. *) -let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) (regions : RegionId.Set.t) - (sv : symbolic_value) (nv : aproj) (ctx : eval_ctx) : eval_ctx = +let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) + (regions : RegionId.Set.t) (sv : symbolic_value) (nv : aproj) + (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = false in let update_shared _ _ = craise meta "Unexpected" in @@ -890,8 +895,9 @@ let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) (regions : R This is a helper function: it might break invariants. *) -let remove_intersecting_aproj_borrows_shared (meta : Meta.meta) (regions : RegionId.Set.t) - (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx = +let remove_intersecting_aproj_borrows_shared (meta : Meta.meta) + (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx + = (* Small helpers *) let can_update_shared = true in let update_shared _ _ = [] in @@ -931,8 +937,8 @@ let remove_intersecting_aproj_borrows_shared (meta : Meta.meta) (regions : Regio Note that the symbolic value at this place is necessarily equal to [sv], which is why we don't give it as parameters. *) -let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId.Set.t) - (proj_ty : rty) (sv : symbolic_value) +let update_intersecting_aproj_loans (meta : Meta.meta) + (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) (subst : abs -> (msymbolic_value * aproj) list -> aproj) (ctx : eval_ctx) : eval_ctx = (* *) @@ -960,7 +966,8 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId. if same_symbolic_id sv sv' then ( sanity_check (sv.sv_ty = sv'.sv_ty) meta; if - projections_intersect meta proj_ty proj_regions sv'.sv_ty abs.regions + projections_intersect meta proj_ty proj_regions sv'.sv_ty + abs.regions then update abs given_back else super#visit_aproj (Some abs) sproj) else super#visit_aproj (Some abs) sproj @@ -983,8 +990,8 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId. Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) -let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) - (ctx : eval_ctx) : (msymbolic_value * aproj) list = +let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) + (sv : symbolic_value) (ctx : eval_ctx) : (msymbolic_value * aproj) list = (* Small helpers for sanity checks *) let found = ref None in let set_found x = @@ -1028,8 +1035,8 @@ let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) -let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) - (nproj : aproj) (ctx : eval_ctx) : eval_ctx = +let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) + (sv : symbolic_value) (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = @@ -1077,8 +1084,8 @@ let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb TODO: factorize with {!update_aproj_loans}? *) -let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) - (nproj : aproj) (ctx : eval_ctx) : eval_ctx = +let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) + (sv : symbolic_value) (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = @@ -1128,12 +1135,12 @@ let update_aproj_loans_to_ended (meta : Meta.meta) (abs_id : AbstractionId.id) (* Create the new value for the projector *) let nproj = AEndedProjLoans (sv, given_back) in (* Insert it *) - let ctx = update_aproj_loans meta abs_id sv nproj ctx in + let ctx = update_aproj_loans meta abs_id sv nproj ctx in (* Return *) ctx -let no_aproj_over_symbolic_in_context (meta : Meta.meta) (sv : symbolic_value) (ctx : eval_ctx) : - unit = +let no_aproj_over_symbolic_in_context (meta : Meta.meta) (sv : symbolic_value) + (ctx : eval_ctx) : unit = (* The visitor *) let obj = object @@ -1211,8 +1218,8 @@ let get_first_non_ignored_aloan_in_abstraction (meta : Meta.meta) (abs : abs) : (* There are loan projections over symbolic values *) Some (SymbolicValue sv) -let lookup_shared_value_opt (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId.id) : - typed_value option = +let lookup_shared_value_opt (meta : Meta.meta) (ctx : eval_ctx) + (bid : BorrowId.id) : typed_value option = match lookup_loan_opt meta ek_all bid ctx with | None -> None | Some (_, lc) -> ( @@ -1221,5 +1228,6 @@ let lookup_shared_value_opt (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId. Some sv | _ -> None) -let lookup_shared_value (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId.id) : typed_value = +let lookup_shared_value (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId.id) + : typed_value = Option.get (lookup_shared_value_opt meta ctx bid) diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index a2550e88..3e1aeef2 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -48,8 +48,8 @@ type proj_kind = LoanProj | BorrowProj Note that 2. and 3. may have a little bit of duplicated code, but hopefully it would make things clearer. *) -let apply_symbolic_expansion_to_target_avalues (config : config) (meta : Meta.meta) - (allow_reborrows : bool) (proj_kind : proj_kind) +let apply_symbolic_expansion_to_target_avalues (config : config) + (meta : Meta.meta) (allow_reborrows : bool) (proj_kind : proj_kind) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = (* Symbolic values contained in the expansion might contain already ended regions *) @@ -123,8 +123,9 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (meta : Meta.me in (* Apply the projector *) let projected_value = - apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow - proj_regions ancestors_regions expansion proj_ty + apply_proj_borrows meta check_symbolic_no_ended ctx + fresh_reborrow proj_regions ancestors_regions expansion + proj_ty in (* Replace *) projected_value.value @@ -150,8 +151,8 @@ let apply_symbolic_expansion_to_avalues (config : config) (meta : Meta.meta) (allow_reborrows : bool) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = let apply_expansion proj_kind ctx = - apply_symbolic_expansion_to_target_avalues config meta allow_reborrows proj_kind - original_sv expansion ctx + apply_symbolic_expansion_to_target_avalues config meta allow_reborrows + proj_kind original_sv expansion ctx in (* First target the loan projectors, then the borrow projectors *) let ctx = apply_expansion LoanProj ctx in @@ -163,8 +164,8 @@ let apply_symbolic_expansion_to_avalues (config : config) (meta : Meta.meta) Simply replace the symbolic values (*not avalues*) in the context with a given value. Will break invariants if not used properly. *) -let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) (original_sv : symbolic_value) - (nv : value) (ctx : eval_ctx) : eval_ctx = +let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) + (original_sv : symbolic_value) (nv : value) (ctx : eval_ctx) : eval_ctx = (* Count *) let replaced = ref false in let replace () = @@ -193,7 +194,9 @@ let apply_symbolic_expansion_non_borrow (config : config) (meta : Meta.meta) (* Apply the expansion to non-abstraction values *) let nv = symbolic_expansion_non_borrow_to_value meta original_sv expansion in let at_most_once = false in - let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in + let ctx = + replace_symbolic_values meta at_most_once original_sv nv.value ctx + in (* Apply the expansion to abstraction values *) let allow_reborrows = false in apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv @@ -209,13 +212,15 @@ let apply_symbolic_expansion_non_borrow (config : config) (meta : Meta.meta) [expand_enumerations] controls the expansion of enumerations: if false, it doesn't allow the expansion of enumerations *containing several variants*. *) -let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (expand_enumerations : bool) - (def_id : TypeDeclId.id) (generics : generic_args) (ctx : eval_ctx) : - symbolic_expansion list = +let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) + (expand_enumerations : bool) (def_id : TypeDeclId.id) + (generics : generic_args) (ctx : eval_ctx) : symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) let def = ctx_lookup_type_decl ctx def_id in - sanity_check (List.length generics.regions = List.length def.generics.regions) meta; + sanity_check + (List.length generics.regions = List.length def.generics.regions) + meta; (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = AssociatedTypes.type_decl_get_inst_norm_variants_fields_rtypes meta ctx def @@ -236,8 +241,8 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (expand_e (* Initialize all the expanded values of all the variants *) List.map initialize variants_fields_types -let compute_expanded_symbolic_tuple_value (meta : Meta.meta) (field_types : rty list) : - symbolic_expansion = +let compute_expanded_symbolic_tuple_value (meta : Meta.meta) + (field_types : rty list) : symbolic_expansion = (* Generate the field values *) let field_values = List.map (fun sv_ty -> mk_fresh_symbolic_value meta sv_ty) field_types @@ -246,7 +251,8 @@ let compute_expanded_symbolic_tuple_value (meta : Meta.meta) (field_types : rty let see = SeAdt (variant_id, field_values) in see -let compute_expanded_symbolic_box_value (meta : Meta.meta) (boxed_ty : rty) : symbolic_expansion = +let compute_expanded_symbolic_box_value (meta : Meta.meta) (boxed_ty : rty) : + symbolic_expansion = (* Introduce a fresh symbolic value *) let boxed_value = mk_fresh_symbolic_value meta boxed_ty in let see = SeAdt (None, [ boxed_value ]) in @@ -261,19 +267,19 @@ let compute_expanded_symbolic_box_value (meta : Meta.meta) (boxed_ty : rty) : sy [expand_enumerations] controls the expansion of enumerations: if [false], it doesn't allow the expansion of enumerations *containing several variants*. *) -let compute_expanded_symbolic_adt_value (meta : Meta.meta) (expand_enumerations : bool) - (adt_id : type_id) (generics : generic_args) (ctx : eval_ctx) : - symbolic_expansion list = +let compute_expanded_symbolic_adt_value (meta : Meta.meta) + (expand_enumerations : bool) (adt_id : type_id) (generics : generic_args) + (ctx : eval_ctx) : symbolic_expansion list = match (adt_id, generics.regions, generics.types) with | TAdtId def_id, _, _ -> - compute_expanded_symbolic_non_assumed_adt_value meta expand_enumerations def_id - generics ctx - | TTuple, [], _ -> [ compute_expanded_symbolic_tuple_value meta generics.types ] + compute_expanded_symbolic_non_assumed_adt_value meta expand_enumerations + def_id generics ctx + | TTuple, [], _ -> + [ compute_expanded_symbolic_tuple_value meta generics.types ] | TAssumed TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value meta boxed_ty ] | _ -> - craise - meta "compute_expanded_symbolic_adt_value: unexpected combination" + craise meta "compute_expanded_symbolic_adt_value: unexpected combination" let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) @@ -380,14 +386,14 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = - apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv see - ctx + apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv + see ctx in (* Call the continuation *) let expr = cf ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching meta original_sv original_sv_place see - expr + S.synthesize_symbolic_expansion_no_branching meta original_sv + original_sv_place see expr (** TODO: simplify and merge with the other expansion function *) let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) @@ -407,23 +413,27 @@ let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) let see = SeMutRef (bid, sv) in (* Expand the symbolic values - we simply perform a substitution (and * check that we perform exactly one substitution) *) - let nv = symbolic_expansion_non_shared_borrow_to_value meta original_sv see in + let nv = + symbolic_expansion_non_shared_borrow_to_value meta original_sv see + in let at_most_once = true in - let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in + let ctx = + replace_symbolic_values meta at_most_once original_sv nv.value ctx + in (* Expand the symbolic avalues *) let allow_reborrows = true in let ctx = - apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv - see ctx + apply_symbolic_expansion_to_avalues config meta allow_reborrows + original_sv see ctx in (* Apply the continuation *) let expr = cf ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching meta original_sv original_sv_place - see expr + S.synthesize_symbolic_expansion_no_branching meta original_sv + original_sv_place see expr | RShared -> - expand_symbolic_value_shared_borrow config meta original_sv original_sv_place - ref_ty cf ctx + expand_symbolic_value_shared_borrow config meta original_sv + original_sv_place ref_ty cf ctx (** A small helper. @@ -441,8 +451,8 @@ let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) We need this continuation separately (i.e., we can't compose it with the continuations in [see_cf_l]) because we perform a join *before* calling it. *) -let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Meta.meta) - (sv : symbolic_value) (sv_place : SA.mplace option) +let apply_branching_symbolic_expansions_non_borrow (config : config) + (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = fun ctx -> @@ -457,15 +467,19 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Met let ctx = match see_opt with | None -> ctx - | Some see -> apply_symbolic_expansion_non_borrow config meta sv see ctx + | Some see -> + apply_symbolic_expansion_non_borrow config meta sv see ctx in (* Debug *) log#ldebug (lazy ("apply_branching_symbolic_expansions_non_borrow: " ^ symbolic_value_to_string ctx0 sv - ^ "\n\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n\n- original context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* Continuation *) cf_br cf_after_join ctx) see_cf_l @@ -484,9 +498,9 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Met let seel = List.map fst see_cf_l in S.synthesize_symbolic_expansion meta sv sv_place seel subterms -let expand_symbolic_bool (config : config) (meta : Meta.meta) (sv : symbolic_value) - (sv_place : SA.mplace option) (cf_true : st_cm_fun) (cf_false : st_cm_fun) - (cf_after_join : st_m_fun) : m_fun = +let expand_symbolic_bool (config : config) (meta : Meta.meta) + (sv : symbolic_value) (sv_place : SA.mplace option) (cf_true : st_cm_fun) + (cf_false : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> (* Compute the expanded value *) let original_sv = sv in @@ -501,8 +515,8 @@ let expand_symbolic_bool (config : config) (meta : Meta.meta) (sv : symbolic_val apply_branching_symbolic_expansions_non_borrow config meta original_sv original_sv_place seel cf_after_join ctx -let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv : symbolic_value) - (sv_place : SA.mplace option) : cm_fun = +let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) + (sv : symbolic_value) (sv_place : SA.mplace option) : cm_fun = fun cf ctx -> (* Debug *) log#ldebug @@ -523,8 +537,8 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv (* Compute the expanded value *) let allow_branching = false in let seel = - compute_expanded_symbolic_adt_value meta allow_branching adt_id generics - ctx + compute_expanded_symbolic_adt_value meta allow_branching adt_id + generics ctx in (* There should be exacly one branch *) let see = Collections.List.to_cons_nil seel in @@ -539,13 +553,12 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv original_sv_place see expr (* Borrows *) | TRef (region, ref_ty, rkind) -> - expand_symbolic_value_borrow config meta original_sv original_sv_place region - ref_ty rkind cf ctx + expand_symbolic_value_borrow config meta original_sv original_sv_place + region ref_ty rkind cf ctx | _ -> - craise - meta - ("expand_symbolic_value_no_branching: unexpected type: " - ^ show_rty rty) + craise meta + ("expand_symbolic_value_no_branching: unexpected type: " + ^ show_rty rty) in (* Debug *) let cc = @@ -554,17 +567,20 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv (lazy ("expand_symbolic_value_no_branching: " ^ symbolic_value_to_string ctx0 sv - ^ "\n\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n\n- original context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* Sanity check: the symbolic value has disappeared *) sanity_check (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta) in (* Continue *) cc cf ctx -let expand_symbolic_adt (config : config) (meta : Meta.meta) (sv : symbolic_value) - (sv_place : SA.mplace option) (cf_branches : st_cm_fun) - (cf_after_join : st_m_fun) : m_fun = +let expand_symbolic_adt (config : config) (meta : Meta.meta) + (sv : symbolic_value) (sv_place : SA.mplace option) + (cf_branches : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("expand_symbolic_adt:" ^ symbolic_value_to_string ctx sv)); @@ -580,19 +596,19 @@ let expand_symbolic_adt (config : config) (meta : Meta.meta) (sv : symbolic_valu let allow_branching = true in (* Compute the expanded value *) let seel = - compute_expanded_symbolic_adt_value meta allow_branching adt_id generics ctx + compute_expanded_symbolic_adt_value meta allow_branching adt_id generics + ctx in (* Apply *) let seel = List.map (fun see -> (Some see, cf_branches)) seel in apply_branching_symbolic_expansions_non_borrow config meta original_sv original_sv_place seel cf_after_join ctx - | _ -> - craise meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) + | _ -> craise meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) -let expand_symbolic_int (config : config) (meta : Meta.meta) (sv : symbolic_value) - (sv_place : SA.mplace option) (int_type : integer_type) - (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) - (cf_after_join : st_m_fun) : m_fun = +let expand_symbolic_int (config : config) (meta : Meta.meta) + (sv : symbolic_value) (sv_place : SA.mplace option) + (int_type : integer_type) (tgts : (scalar_value * st_cm_fun) list) + (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) sanity_check (sv.sv_ty = TLiteral (TInteger int_type)) meta; (* For all the branches of the switch, we expand the symbolic value @@ -620,7 +636,8 @@ let expand_symbolic_int (config : config) (meta : Meta.meta) (sv : symbolic_valu an enumeration with strictly more than one variant, a slice, etc.) or if we need to expand a recursive type (because this leads to looping). *) -let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : cm_fun = +let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : + cm_fun = fun cf ctx -> (* The visitor object, to look for symbolic values in the concrete environment *) let obj = @@ -661,31 +678,27 @@ let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : (match def.kind with | Struct _ | Enum ([] | [ _ ]) -> () | Enum (_ :: _) -> - craise - meta - ("Attempted to greedily expand a symbolic enumeration \ - with > 1 variants (option \ - [greedy_expand_symbolics_with_borrows] of [config]): " - ^ name_to_string ctx def.name) + craise meta + ("Attempted to greedily expand a symbolic enumeration with > \ + 1 variants (option [greedy_expand_symbolics_with_borrows] \ + of [config]): " + ^ name_to_string ctx def.name) | Opaque -> craise meta "Attempted to greedily expand an opaque type"); (* Also, we need to check if the definition is recursive *) if ctx_type_decl_is_rec ctx def_id then - craise - meta - ("Attempted to greedily expand a recursive definition \ - (option [greedy_expand_symbolics_with_borrows] of \ - [config]): " - ^ name_to_string ctx def.name) + craise meta + ("Attempted to greedily expand a recursive definition (option \ + [greedy_expand_symbolics_with_borrows] of [config]): " + ^ name_to_string ctx def.name) else expand_symbolic_value_no_branching config meta sv None | TAdt ((TTuple | TAssumed TBox), _) | TRef (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config meta sv None | TAdt (TAssumed (TArray | TSlice | TStr), _) -> (* We can't expand those *) - craise - meta - "Attempted to greedily expand an ADT which can't be expanded " + craise meta + "Attempted to greedily expand an ADT which can't be expanded " | TVar _ | TLiteral _ | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> craise meta "Unreachable" in @@ -695,7 +708,8 @@ let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : (* Apply *) expand cf ctx -let greedy_expand_symbolic_values (config : config) (meta : Meta.meta) : cm_fun = +let greedy_expand_symbolic_values (config : config) (meta : Meta.meta) : cm_fun + = fun cf ctx -> if Config.greedy_expand_symbolics_with_borrows then ( log#ldebug (lazy "greedy_expand_symbolic_values"); diff --git a/compiler/InterpreterExpansion.mli b/compiler/InterpreterExpansion.mli index 8b0b386a..2ea27ea6 100644 --- a/compiler/InterpreterExpansion.mli +++ b/compiler/InterpreterExpansion.mli @@ -12,7 +12,12 @@ type proj_kind = LoanProj | BorrowProj This function does *not* update the synthesis. *) val apply_symbolic_expansion_non_borrow : - config -> Meta.meta -> symbolic_value -> symbolic_expansion -> eval_ctx -> eval_ctx + config -> + Meta.meta -> + symbolic_value -> + symbolic_expansion -> + eval_ctx -> + eval_ctx (** Expand a symhbolic value, without branching *) val expand_symbolic_value_no_branching : @@ -32,7 +37,13 @@ val expand_symbolic_value_no_branching : then call it). *) val expand_symbolic_adt : - config -> Meta.meta -> symbolic_value -> SA.mplace option -> st_cm_fun -> st_m_fun -> m_fun + config -> + Meta.meta -> + symbolic_value -> + SA.mplace option -> + st_cm_fun -> + st_m_fun -> + m_fun (** Expand a symbolic boolean. @@ -41,7 +52,7 @@ val expand_symbolic_adt : parameter (here, there are exactly two branches). *) val expand_symbolic_bool : - config -> + config -> Meta.meta -> symbolic_value -> SA.mplace option -> @@ -70,7 +81,7 @@ val expand_symbolic_bool : switch. The continuation is thus for the execution *after* the switch. *) val expand_symbolic_int : - config -> + config -> Meta.meta -> symbolic_value -> SA.mplace option -> diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 7045d886..3d01024b 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -37,7 +37,8 @@ let expand_primitively_copyable_at_place (config : config) (meta : Meta.meta) | None -> cf ctx | Some sv -> let cc = - expand_symbolic_value_no_branching config meta sv (Some (mk_mplace meta p ctx)) + expand_symbolic_value_no_branching config meta sv + (Some (mk_mplace meta p ctx)) in comp cc expand cf ctx in @@ -49,14 +50,18 @@ let expand_primitively_copyable_at_place (config : config) (meta : Meta.meta) We also check that the value *doesn't contain bottoms or reserved borrows*. *) -let read_place (meta : Meta.meta) (access : access_kind) (p : place) (cf : typed_value -> m_fun) : - m_fun = +let read_place (meta : Meta.meta) (access : access_kind) (p : place) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> let v = read_place meta access p ctx in (* Check that there are no bottoms in the value *) - cassert (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value"; + cassert + (not (bottom_in_value ctx.ended_regions v)) + meta "There should be no bottoms in the value"; (* Check that there are no reserved borrows in the value *) - cassert (not (reserved_in_value v)) meta "There should be no reserved borrows in the value"; + cassert + (not (reserved_in_value v)) + meta "There should be no reserved borrows in the value"; (* Call the continuation *) cf v ctx @@ -80,15 +85,16 @@ let access_rplace_reorganize_and_read (config : config) (meta : Meta.meta) (* Compose *) comp cc read_place cf ctx -let access_rplace_reorganize (config : config) (meta : Meta.meta) (expand_prim_copy : bool) - (access : access_kind) (p : place) : cm_fun = +let access_rplace_reorganize (config : config) (meta : Meta.meta) + (expand_prim_copy : bool) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> access_rplace_reorganize_and_read config meta expand_prim_copy access p (fun _v -> cf) ctx (** Convert an operand constant operand value to a typed value *) -let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) : typed_value = +let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) + : typed_value = (* Check the type while converting - we actually need some information * contained in the type *) log#ldebug @@ -118,13 +124,14 @@ let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) parameter to control this copy ([allow_adt_copy]). Note that here by ADT we mean the user-defined ADTs (not tuples or assumed types). *) -let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) - (v : typed_value) : eval_ctx * typed_value = +let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) + (ctx : eval_ctx) (v : typed_value) : eval_ctx * typed_value = log#ldebug (lazy ("copy_value: " ^ typed_value_to_string ~meta:(Some meta) ctx v - ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ "\n- context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Remark: at some point we rewrote this function to use iterators, but then * we reverted the changes: the result was less clear actually. In particular, * the fact that we have exhaustive matches below makes very obvious the cases @@ -137,7 +144,7 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) | TAdt (TAssumed TBox, _) -> exec_raise meta "Can't copy an assumed value other than Option" | TAdt (TAdtId _, _) as ty -> - sanity_check (allow_adt_copy || ty_is_primitively_copyable ty) meta + sanity_check (allow_adt_copy || ty_is_primitively_copyable ty) meta | TAdt (TTuple, _) -> () (* Ok *) | TAdt ( TAssumed (TSlice | TArray), @@ -147,7 +154,9 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) const_generics = []; trait_refs = []; } ) -> - exec_assert (ty_is_primitively_copyable ty) meta "The type is not primitively copyable" + exec_assert + (ty_is_primitively_copyable ty) + meta "The type is not primitively copyable" | _ -> exec_raise meta "Unreachable"); let ctx, fields = List.fold_left_map @@ -180,7 +189,9 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) * Note that in the general case, copy is a trait: copying values * thus requires calling the proper function. Here, we copy values * for very simple types such as integers, shared borrows, etc. *) - cassert (ty_is_primitively_copyable (Substitute.erase_regions sp.sv_ty)) meta "Not primitively copyable"; + cassert + (ty_is_primitively_copyable (Substitute.erase_regions sp.sv_ty)) + meta "Not primitively copyable"; (* If the type is copyable, we simply return the current value. Side * remark: what is important to look at when copying symbolic values * is symbolic expansion. The important subcase is the expansion of shared @@ -225,7 +236,8 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) what we do in the formalization (because we don't enforce the same constraints as MIR in the formalization). *) -let prepare_eval_operand_reorganize (config : config) (meta : Meta.meta) (op : operand) : cm_fun = +let prepare_eval_operand_reorganize (config : config) (meta : Meta.meta) + (op : operand) : cm_fun = fun cf ctx -> let prepare : cm_fun = fun cf ctx -> @@ -249,14 +261,16 @@ let prepare_eval_operand_reorganize (config : config) (meta : Meta.meta) (op : o prepare cf ctx (** Evaluate an operand, without reorganizing the context before *) -let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operand) - (cf : typed_value -> m_fun) : m_fun = +let eval_operand_no_reorganize (config : config) (meta : Meta.meta) + (op : operand) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("eval_operand_no_reorganize: op: " ^ operand_to_string ctx op - ^ "\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n- ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* Evaluate *) match op with | Constant cv -> ( @@ -330,11 +344,14 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan let copy cf v : m_fun = fun ctx -> (* Sanity checks *) - exec_assert (not (bottom_in_value ctx.ended_regions v)) meta "Can not copy a value containing bottom"; - sanity_check ( - Option.is_none - (find_first_primitively_copyable_sv_with_borrows - ctx.type_ctx.type_infos v)) meta; + exec_assert + (not (bottom_in_value ctx.ended_regions v)) + meta "Can not copy a value containing bottom"; + sanity_check + (Option.is_none + (find_first_primitively_copyable_sv_with_borrows + ctx.type_ctx.type_infos v)) + meta; (* Actually perform the copy *) let allow_adt_copy = false in let ctx, v = copy_value meta allow_adt_copy config ctx v in @@ -351,7 +368,9 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan let move cf v : m_fun = fun ctx -> (* Check that there are no bottoms in the value we are about to move *) - exec_assert (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value we are about to move"; + exec_assert + (not (bottom_in_value ctx.ended_regions v)) + meta "There should be no bottoms in the value we are about to move"; let bottom : typed_value = { value = VBottom; ty = v.ty } in let ctx = write_place meta access p bottom ctx in cf v ctx @@ -359,14 +378,15 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan (* Compose and apply *) comp cc move cf ctx -let eval_operand (config : config) (meta : Meta.meta) (op : operand) (cf : typed_value -> m_fun) : - m_fun = +let eval_operand (config : config) (meta : Meta.meta) (op : operand) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("eval_operand: op: " ^ operand_to_string ctx op ^ "\n- ctx:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* We reorganize the context, then evaluate the operand *) comp (prepare_eval_operand_reorganize config meta op) @@ -377,8 +397,8 @@ let eval_operand (config : config) (meta : Meta.meta) (op : operand) (cf : typed See [prepare_eval_operand_reorganize]. *) -let prepare_eval_operands_reorganize (config : config) (meta : Meta.meta) (ops : operand list) : - cm_fun = +let prepare_eval_operands_reorganize (config : config) (meta : Meta.meta) + (ops : operand list) : cm_fun = fold_left_apply_continuation (prepare_eval_operand_reorganize config meta) ops (** Evaluate several operands. *) @@ -389,23 +409,23 @@ let eval_operands (config : config) (meta : Meta.meta) (ops : operand list) let prepare = prepare_eval_operands_reorganize config meta ops in (* Evaluate the operands *) let eval = - fold_left_list_apply_continuation (eval_operand_no_reorganize config meta) ops + fold_left_list_apply_continuation + (eval_operand_no_reorganize config meta) + ops in (* Compose and apply *) comp prepare eval cf ctx -let eval_two_operands (config : config) (meta : Meta.meta) (op1 : operand) (op2 : operand) - (cf : typed_value * typed_value -> m_fun) : m_fun = +let eval_two_operands (config : config) (meta : Meta.meta) (op1 : operand) + (op2 : operand) (cf : typed_value * typed_value -> m_fun) : m_fun = let eval_op = eval_operands config meta [ op1; op2 ] in let use_res cf res = - match res with - | [ v1; v2 ] -> cf (v1, v2) - | _ -> craise meta "Unreachable" + match res with [ v1; v2 ] -> cf (v1, v2) | _ -> craise meta "Unreachable" in comp eval_op use_res cf -let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) (op : operand) - (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) + (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operand *) let eval_op = eval_operand config meta op in (* Apply the unop *) @@ -452,8 +472,8 @@ let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) (o in comp eval_op apply cf -let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) (op : operand) - (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) + (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operand *) let eval_op = eval_operand config meta op in @@ -479,8 +499,8 @@ let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) (o (* Compose and apply *) comp eval_op apply cf ctx -let eval_unary_op (config : config) (meta : Meta.meta) (unop : unop) (op : operand) - (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op (config : config) (meta : Meta.meta) (unop : unop) + (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with | ConcreteMode -> eval_unary_op_concrete config meta unop op cf | SymbolicMode -> eval_unary_op_symbolic config meta unop op cf @@ -488,15 +508,17 @@ let eval_unary_op (config : config) (meta : Meta.meta) (unop : unop) (op : opera (** Small helper for [eval_binary_op_concrete]: computes the result of applying the binop *after* the operands have been successfully evaluated *) -let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typed_value) - (v2 : typed_value) : (typed_value, eval_error) result = +let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) + (v1 : typed_value) (v2 : typed_value) : (typed_value, eval_error) result = (* Equality check binops (Eq, Ne) accept values from a wide variety of types. * The remaining binops only operate on scalars. *) if binop = Eq || binop = Ne then ( (* Equality operations *) exec_assert (v1.ty = v2.ty) meta "TODO: error message"; (* Equality/inequality check is primitive only for a subset of types *) - exec_assert (ty_is_primitively_copyable v1.ty) meta "Type is not primitively copyable"; + exec_assert + (ty_is_primitively_copyable v1.ty) + meta "Type is not primitively copyable"; let b = v1 = v2 in Ok { value = VLiteral (VBool b); ty = TLiteral TBool }) else @@ -558,8 +580,9 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typ | Ne | Eq -> craise meta "Unreachable") | _ -> craise meta "Invalid inputs for binop" -let eval_binary_op_concrete (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) - (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_binary_op_concrete (config : config) (meta : Meta.meta) (binop : binop) + (op1 : operand) (op2 : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operands *) let eval_ops = eval_two_operands config meta op1 op2 in (* Compute the result of the binop *) @@ -570,8 +593,9 @@ let eval_binary_op_concrete (config : config) (meta : Meta.meta) (binop : binop) (* Compose and apply *) comp eval_ops compute cf -let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) - (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) + (op1 : operand) (op2 : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operands *) let eval_ops = eval_two_operands config meta op1 op2 in @@ -585,7 +609,9 @@ let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) (* Equality operations *) sanity_check (v1.ty = v2.ty) meta; (* Equality/inequality check is primitive only for a subset of types *) - exec_assert (ty_is_primitively_copyable v1.ty) meta "The type is not primitively copyable"; + exec_assert + (ty_is_primitively_copyable v1.ty) + meta "The type is not primitively copyable"; TLiteral TBool) else (* Other operations: input types are integers *) @@ -617,14 +643,15 @@ let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) (* Compose and apply *) comp eval_ops compute cf ctx -let eval_binary_op (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) - (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_binary_op (config : config) (meta : Meta.meta) (binop : binop) + (op1 : operand) (op2 : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with | ConcreteMode -> eval_binary_op_concrete config meta binop op1 op2 cf | SymbolicMode -> eval_binary_op_symbolic config meta binop op1 op2 cf -let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) (bkind : borrow_kind) - (cf : typed_value -> m_fun) : m_fun = +let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) + (bkind : borrow_kind) (cf : typed_value -> m_fun) : m_fun = fun ctx -> match bkind with | BShared | BTwoPhaseMut | BShallow -> @@ -715,8 +742,9 @@ let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) (bkind : bo (* Compose and apply *) comp prepare eval cf ctx -let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : aggregate_kind) - (ops : operand list) (cf : typed_value -> m_fun) : m_fun = +let eval_rvalue_aggregate (config : config) (meta : Meta.meta) + (aggregate_kind : aggregate_kind) (ops : operand list) + (cf : typed_value -> m_fun) : m_fun = (* Evaluate the operands *) let eval_ops = eval_operands config meta ops in (* Compute the value *) @@ -737,16 +765,18 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : | TAdtId def_id -> (* Sanity checks *) let type_decl = ctx_lookup_type_decl ctx def_id in - sanity_check ( - List.length type_decl.generics.regions - = List.length generics.regions) meta; + sanity_check + (List.length type_decl.generics.regions + = List.length generics.regions) + meta; let expected_field_types = AssociatedTypes.ctx_adt_get_inst_norm_field_etypes meta ctx def_id opt_variant_id generics in - sanity_check ( - expected_field_types - = List.map (fun (v : typed_value) -> v.ty) values) meta; + sanity_check + (expected_field_types + = List.map (fun (v : typed_value) -> v.ty) values) + meta; (* Construct the value *) let av : adt_value = { variant_id = opt_variant_id; field_values = values } @@ -758,7 +788,9 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : | TAssumed _ -> craise meta "Unreachable") | AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) - sanity_check (List.for_all (fun (v : typed_value) -> v.ty = ety) values) meta; + sanity_check + (List.for_all (fun (v : typed_value) -> v.ty = ety) values) + meta; (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in sanity_check (len = Z.of_int (List.length values)) meta; @@ -782,8 +814,8 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : (* Compose and apply *) comp eval_ops compute cf -let eval_rvalue_not_global (config : config) (meta : Meta.meta) (rvalue : rvalue) - (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_rvalue_not_global (config : config) (meta : Meta.meta) + (rvalue : rvalue) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> log#ldebug (lazy "eval_rvalue"); (* Small helpers *) @@ -797,14 +829,14 @@ let eval_rvalue_not_global (config : config) (meta : Meta.meta) (rvalue : rvalue | Use op -> comp_wrap (eval_operand config meta op) ctx | RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config meta p bkind) ctx | UnaryOp (unop, op) -> eval_unary_op config meta unop op cf ctx - | BinaryOp (binop, op1, op2) -> eval_binary_op config meta binop op1 op2 cf ctx + | BinaryOp (binop, op1, op2) -> + eval_binary_op config meta binop op1 op2 cf ctx | Aggregate (aggregate_kind, ops) -> comp_wrap (eval_rvalue_aggregate config meta aggregate_kind ops) ctx | Discriminant _ -> - craise - meta - "Unreachable: discriminant reads should have been eliminated from \ - the AST" + craise meta + "Unreachable: discriminant reads should have been eliminated from the \ + AST" | Global _ -> craise meta "Unreachable" let eval_fake_read (config : config) (meta : Meta.meta) (p : place) : cm_fun = @@ -815,7 +847,9 @@ let eval_fake_read (config : config) (meta : Meta.meta) (p : place) : cm_fun = in let cf_continue cf v : m_fun = fun ctx -> - cassert (not (bottom_in_value ctx.ended_regions v)) meta "Fake read: the value contains bottom"; + cassert + (not (bottom_in_value ctx.ended_regions v)) + meta "Fake read: the value contains bottom"; cf ctx in comp cf_prepare cf_continue cf ctx diff --git a/compiler/InterpreterExpressions.mli b/compiler/InterpreterExpressions.mli index 76627c40..0fb12180 100644 --- a/compiler/InterpreterExpressions.mli +++ b/compiler/InterpreterExpressions.mli @@ -12,7 +12,8 @@ open InterpreterPaths This function doesn't reorganize the context to make sure we can read the place. If needs be, you should call {!InterpreterPaths.update_ctx_along_read_place} first. *) -val read_place : Meta.meta -> access_kind -> place -> (typed_value -> m_fun) -> m_fun +val read_place : + Meta.meta -> access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Auxiliary function. @@ -31,7 +32,13 @@ val read_place : Meta.meta -> access_kind -> place -> (typed_value -> m_fun) -> primitively copyable and contain borrows. *) val access_rplace_reorganize_and_read : - config -> Meta.meta -> bool -> access_kind -> place -> (typed_value -> m_fun) -> m_fun + config -> + Meta.meta -> + bool -> + access_kind -> + place -> + (typed_value -> m_fun) -> + m_fun (** Evaluate an operand. @@ -42,7 +49,8 @@ val access_rplace_reorganize_and_read : of the environment, before evaluating all the operands at once. Use {!eval_operands} instead. *) -val eval_operand : config -> Meta.meta -> operand -> (typed_value -> m_fun) -> m_fun +val eval_operand : + config -> Meta.meta -> operand -> (typed_value -> m_fun) -> m_fun (** Evaluate several operands at once. *) val eval_operands : @@ -56,7 +64,11 @@ val eval_operands : reads should have been eliminated from the AST. *) val eval_rvalue_not_global : - config -> Meta.meta -> rvalue -> ((typed_value, eval_error) result -> m_fun) -> m_fun + config -> + Meta.meta -> + rvalue -> + ((typed_value, eval_error) result -> m_fun) -> + m_fun (** Evaluate a fake read (update the context so that we can read a place) *) val eval_fake_read : config -> Meta.meta -> place -> cm_fun diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 89015f71..d369aef9 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -15,7 +15,8 @@ open Errors let log = Logging.loops_log (** Evaluate a loop in concrete mode *) -let eval_loop_concrete (meta : Meta.meta) (eval_loop_body : st_cm_fun) : st_cm_fun = +let eval_loop_concrete (meta : Meta.meta) (eval_loop_body : st_cm_fun) : + st_cm_fun = fun cf ctx -> (* We need a loop id for the [LoopReturn]. In practice it won't be used (it is useful only for the symbolic execution *) @@ -68,7 +69,10 @@ let eval_loop_symbolic (config : config) (meta : meta) fun cf ctx -> (* Debug *) log#ldebug - (lazy ("eval_loop_symbolic:\nContext:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n")); + (lazy + ("eval_loop_symbolic:\nContext:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\n")); (* Generate a fresh loop id *) let loop_id = fresh_loop_id () in @@ -81,11 +85,15 @@ let eval_loop_symbolic (config : config) (meta : meta) (* Debug *) log#ldebug (lazy - ("eval_loop_symbolic:\nInitial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx - ^ "\n\nFixed point:\n" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx)); + ("eval_loop_symbolic:\nInitial context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\nFixed point:\n" + ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx)); (* Compute the loop input parameters *) - let fresh_sids, input_svalues = compute_fp_ctx_symbolic_values meta ctx fp_ctx in + let fresh_sids, input_svalues = + compute_fp_ctx_symbolic_values meta ctx fp_ctx + in let fp_input_svalues = List.map (fun sv -> sv.sv_id) input_svalues in (* Synthesize the end of the function - we simply match the context at the @@ -122,11 +130,13 @@ let eval_loop_symbolic (config : config) (meta : meta) (lazy ("eval_loop_symbolic: about to match the fixed-point context with the \ original context:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx - ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + - src ctx (fixed-point ctx)" + ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx + ^ "\n\n-tgt ctx (original context):\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); let end_expr : SymbolicAst.expression option = - match_ctx_with_target config meta loop_id true fp_bl_corresp fp_input_svalues - fixed_ids fp_ctx cf ctx + match_ctx_with_target config meta loop_id true fp_bl_corresp + fp_input_svalues fixed_ids fp_ctx cf ctx in log#ldebug (lazy @@ -155,8 +165,10 @@ let eval_loop_symbolic (config : config) (meta : meta) (lazy ("eval_loop_symbolic: about to match the fixed-point context \ with the context at a continue:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx - ^ "\n\n-tgt ctx (ctx at continue):\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + - src ctx (fixed-point ctx)" + ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx + ^ "\n\n-tgt ctx (ctx at continue):\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); let cc = match_ctx_with_target config meta loop_id false fp_bl_corresp fp_input_svalues fixed_ids fp_ctx diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 2de5aed0..660e542d 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -261,6 +261,7 @@ module type Matcher = sig Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) val meta : Meta.meta + val match_typed_values : eval_ctx -> eval_ctx -> typed_value -> typed_value -> typed_value @@ -348,6 +349,7 @@ module type MatchJoinState = sig (** The abstractions introduced when performing the matches *) val nabs : abs list ref + val meta : Meta.meta end @@ -356,8 +358,8 @@ end Returns: (fixed, new abs, new dummies) *) -let ctx_split_fixed_new (meta : Meta.meta) (fixed_ids : ids_sets) (ctx : eval_ctx) : - env * abs list * typed_value list = +let ctx_split_fixed_new (meta : Meta.meta) (fixed_ids : ids_sets) + (ctx : eval_ctx) : env * abs list * typed_value list = let is_fresh_did (id : DummyVarId.id) : bool = not (DummyVarId.Set.mem id fixed_ids.dids) in diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index f5bd4a35..7ddf55c1 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -121,8 +121,8 @@ let cleanup_fresh_values (fixed_ids : ids_sets) : cm_fun = - also end the borrows which appear in fresh anonymous values and don't contain loans - end the fresh region abstractions which can be ended (no loans) *) -let cleanup_fresh_values_and_abs (config : config) (meta : Meta.meta) (fixed_ids : ids_sets) : - cm_fun = +let cleanup_fresh_values_and_abs (config : config) (meta : Meta.meta) + (fixed_ids : ids_sets) : cm_fun = fun cf ctx -> comp (end_useless_fresh_borrows_and_abs config meta fixed_ids) @@ -136,8 +136,8 @@ let cleanup_fresh_values_and_abs (config : config) (meta : Meta.meta) (fixed_ids called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (old_abs_ids : AbstractionId.Set.t) - (ctx : eval_ctx) : eval_ctx = +let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) + (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) let is_borrow (av : typed_avalue) : bool = @@ -187,7 +187,8 @@ let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (old_abs_ids : Abstrac { ctx with env } -let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_fun = +let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : + cm_fun = fun cf ctx0 -> let ctx = ctx0 in (* Compute the set of borrows which appear in the abstractions, so that @@ -357,7 +358,11 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f TODO: implement this more general behavior. *) method! visit_symbolic_value env sv = - cassert (not (symbolic_value_has_borrows ctx sv)) meta "There should be no symbolic values with borrows inside the abstraction"; + cassert + (not (symbolic_value_has_borrows ctx sv)) + meta + "There should be no symbolic values with borrows inside the \ + abstraction"; super#visit_symbolic_value env sv end in @@ -433,12 +438,12 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f SymbolicAst.IntroSymbolic (ctx, None, sv, VaSingleValue v, e)) e !sid_subst) -let prepare_ashared_loans_no_synth (meta : Meta.meta) (loop_id : LoopId.id) (ctx : eval_ctx) : - eval_ctx = +let prepare_ashared_loans_no_synth (meta : Meta.meta) (loop_id : LoopId.id) + (ctx : eval_ctx) : eval_ctx = get_cf_ctx_no_synth meta (prepare_ashared_loans meta (Some loop_id)) ctx -let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id : LoopId.id) - (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : +let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) + (loop_id : LoopId.id) (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : eval_ctx * ids_sets * abs RegionGroupId.Map.t = (* The continuation for when we exit the loop - we register the environments upon loop *reentry*, and synthesize nothing by @@ -544,7 +549,8 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id (* Join the context with the context at the loop entry *) let (_, _), ctx2 = - loop_join_origin_with_continue_ctxs config meta loop_id fixed_ids ctx1 !ctxs + loop_join_origin_with_continue_ctxs config meta loop_id fixed_ids ctx1 + !ctxs in ctxs := []; ctx2 @@ -582,10 +588,9 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id let max_num_iter = Config.loop_fixed_point_max_num_iters in let rec compute_fixed_point (ctx : eval_ctx) (i0 : int) (i : int) : eval_ctx = if i = 0 then - craise - meta - ("Could not compute a loop fixed point in " ^ string_of_int i0 - ^ " iterations") + craise meta + ("Could not compute a loop fixed point in " ^ string_of_int i0 + ^ " iterations") else (* Evaluate the loop body to register the different contexts upon reentry *) let _ = eval_loop_body cf_exit_loop_body ctx in @@ -694,12 +699,14 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id in (* By default, the [SynthInput] abs can't end *) let ctx = ctx_set_abs_can_end meta ctx abs_id true in - sanity_check ( - let abs = ctx_lookup_abs ctx abs_id in - abs.kind = SynthInput rg_id) meta; + sanity_check + (let abs = ctx_lookup_abs ctx abs_id in + abs.kind = SynthInput rg_id) + meta; (* End this abstraction *) let ctx = - InterpreterBorrows.end_abstraction_no_synth config meta abs_id ctx + InterpreterBorrows.end_abstraction_no_synth config meta abs_id + ctx in (* Explore the context, and check which abstractions are not there anymore *) let ids, _ = compute_ctx_ids ctx in @@ -718,7 +725,11 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id let _ = RegionGroupId.Map.iter (fun _ ids -> - cassert (AbstractionId.Set.disjoint !aids_union ids) meta "The sets of abstractions we need to end per region group are not pairwise disjoint"; + cassert + (AbstractionId.Set.disjoint !aids_union ids) + meta + "The sets of abstractions we need to end per region group are not \ + pairwise disjoint"; aids_union := AbstractionId.Set.union ids !aids_union) !fp_ended_aids in @@ -777,7 +788,8 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id ^ AbstractionId.to_string !id0)); (* Note that we merge *into* [id0] *) let fp', id0' = - merge_into_abstraction meta loop_id abs_kind false !fp id !id0 + merge_into_abstraction meta loop_id abs_kind false !fp id + !id0 in fp := fp'; id0 := id0'; @@ -850,13 +862,17 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id (* Return *) (fp, fixed_ids, rg_to_abs) -let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_sets) - (src_ctx : eval_ctx) (tgt_ctx : eval_ctx) : borrow_loan_corresp = +let compute_fixed_point_id_correspondance (meta : Meta.meta) + (fixed_ids : ids_sets) (src_ctx : eval_ctx) (tgt_ctx : eval_ctx) : + borrow_loan_corresp = log#ldebug (lazy ("compute_fixed_point_id_correspondance:\n\n- fixed_ids:\n" - ^ show_ids_sets fixed_ids ^ "\n\n- src_ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) src_ctx - ^ "\n\n- tgt_ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx ^ "\n\n")); + ^ show_ids_sets fixed_ids ^ "\n\n- src_ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n\n- tgt_ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx + ^ "\n\n")); let filt_src_env, _, _ = ctx_split_fixed_new meta fixed_ids src_ctx in let filt_src_ctx = { src_ctx with env = filt_src_env } in @@ -886,8 +902,8 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in let lookup_in_src id = lookup_shared_loan id src_ctx in Option.get - (match_ctxs meta check_equiv fixed_ids lookup_in_tgt lookup_in_src filt_tgt_ctx - filt_src_ctx) + (match_ctxs meta check_equiv fixed_ids lookup_in_tgt lookup_in_src + filt_tgt_ctx filt_src_ctx) in log#ldebug @@ -984,8 +1000,8 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se loan_to_borrow_id_map = tgt_loan_to_borrow; } -let compute_fp_ctx_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) (fp_ctx : eval_ctx) : - SymbolicValueId.Set.t * symbolic_value list = +let compute_fp_ctx_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) + (fp_ctx : eval_ctx) : SymbolicValueId.Set.t * symbolic_value list = let old_ids, _ = compute_ctx_ids ctx in let fp_ids, fp_ids_maps = compute_ctx_ids fp_ctx in let fresh_sids = SymbolicValueId.Set.diff fp_ids.sids old_ids.sids in diff --git a/compiler/InterpreterLoopsFixedPoint.mli b/compiler/InterpreterLoopsFixedPoint.mli index 54e4d780..4fc36598 100644 --- a/compiler/InterpreterLoopsFixedPoint.mli +++ b/compiler/InterpreterLoopsFixedPoint.mli @@ -77,7 +77,7 @@ val prepare_ashared_loans : Meta.meta -> loop_id option -> Cps.cm_fun the values which are read or modified (some symbolic values may be ignored). *) val compute_loop_entry_fixed_point : - config -> + config -> Meta.meta -> loop_id -> Cps.st_cm_fun -> @@ -170,4 +170,7 @@ val compute_fixed_point_id_correspondance : - the list of input symbolic values *) val compute_fp_ctx_symbolic_values : - Meta.meta -> eval_ctx -> eval_ctx -> symbolic_value_id_set * symbolic_value list + Meta.meta -> + eval_ctx -> + eval_ctx -> + symbolic_value_id_set * symbolic_value list diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 8153ef08..020e812a 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -19,8 +19,8 @@ let log = Logging.loops_join_ctxs_log called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (old_abs_ids : AbstractionId.Set.t) - (ctx : eval_ctx) : eval_ctx = +let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) + (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) let is_borrow (av : typed_avalue) : bool = @@ -136,7 +136,9 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids - ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n")); + ^ "\n\n- ctx0:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n")); let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in @@ -171,14 +173,16 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx: after converting values to abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n" - )); + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\n")); log#ldebug (lazy ("collapse_ctx: after decomposing the shared values in the abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n" - )); + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\n")); (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in @@ -252,13 +256,14 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) ^ AbstractionId.to_string abs_id1 ^ " into " ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" ^ eval_ctx_to_string ~meta:(Some meta) !ctx)); + ^ ":\n\n" + ^ eval_ctx_to_string ~meta:(Some meta) !ctx)); (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = - merge_into_abstraction meta abs_kind can_end merge_funs !ctx - abs_id1 abs_id0 + merge_into_abstraction meta abs_kind can_end merge_funs + !ctx abs_id1 abs_id0 in ctx := nctx; @@ -272,7 +277,9 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids - ^ "\n\n- after collapse:\n" ^ eval_ctx_to_string ~meta:(Some meta) !ctx ^ "\n\n")); + ^ "\n\n- after collapse:\n" + ^ eval_ctx_to_string ~meta:(Some meta) !ctx + ^ "\n\n")); (* Reorder the loans and borrows in the fresh abstractions *) let ctx = reorder_loans_borrows_in_fresh_abs meta old_ids.aids !ctx in @@ -281,13 +288,14 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- after collapse and reorder borrows/loans:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n")); + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\n")); (* Return the new context *) ctx -let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id) (ctx : eval_ctx) - : merge_duplicates_funcs = +let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) + (loop_id : LoopId.id) (ctx : eval_ctx) : merge_duplicates_funcs = (* Rem.: the merge functions raise exceptions (that we catch). *) let module S : MatchJoinState = struct let meta = meta @@ -372,9 +380,10 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id merge_ashared_loans; } -let merge_into_abstraction (meta : Meta.meta) (loop_id : LoopId.id) (abs_kind : abs_kind) - (can_end : bool) (ctx : eval_ctx) (aid0 : AbstractionId.id) - (aid1 : AbstractionId.id) : eval_ctx * AbstractionId.id = +let merge_into_abstraction (meta : Meta.meta) (loop_id : LoopId.id) + (abs_kind : abs_kind) (can_end : bool) (ctx : eval_ctx) + (aid0 : AbstractionId.id) (aid1 : AbstractionId.id) : + eval_ctx * AbstractionId.id = let merge_funs = mk_collapse_ctx_merge_duplicate_funs meta loop_id ctx in merge_into_abstraction meta abs_kind can_end (Some merge_funs) ctx aid0 aid1 @@ -385,14 +394,14 @@ let merge_into_abstraction (meta : Meta.meta) (loop_id : LoopId.id) (abs_kind : We do this because when we join environments, we may introduce duplicated loans and borrows. See the explanations for {!join_ctxs}. *) -let collapse_ctx_with_merge (meta : Meta.meta) (loop_id : LoopId.id) (old_ids : ids_sets) - (ctx : eval_ctx) : eval_ctx = +let collapse_ctx_with_merge (meta : Meta.meta) (loop_id : LoopId.id) + (old_ids : ids_sets) (ctx : eval_ctx) : eval_ctx = let merge_funs = mk_collapse_ctx_merge_duplicate_funs meta loop_id ctx in try collapse_ctx meta loop_id (Some merge_funs) old_ids ctx with ValueMatchFailure _ -> craise meta "Unexpected" -let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) - (ctx1 : eval_ctx) : ctx_or_update = +let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) + (ctx0 : eval_ctx) (ctx1 : eval_ctx) : ctx_or_update = (* Debug *) log#ldebug (lazy @@ -414,9 +423,11 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (lazy ("join_suffixes:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx0 with env = List.rev env0 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) + { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx1 with env = List.rev env1 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) + { ctx1 with env = List.rev env1 } ^ "\n\n")); (* Sanity check: there are no values/abstractions which should be in the prefix *) @@ -428,7 +439,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c | EBinding (BDummy did, _) -> sanity_check (not (DummyVarId.Set.mem did fixed_ids.dids)) meta | EAbs abs -> - sanity_check (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) meta + sanity_check + (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) + meta | EFrame -> (* This should have been eliminated *) craise meta "Unreachable" @@ -468,7 +481,8 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c are not in the prefix anymore *) if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Still in the prefix: match the values *) - cassert (b0 = b1) meta "Bindings are not the same. We are not in the prefix anymore"; + cassert (b0 = b1) meta + "Bindings are not the same. We are not in the prefix anymore"; let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in let var = EBinding (BDummy b, v) in @@ -490,8 +504,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (* Variable bindings *must* be in the prefix and consequently their ids must be the same *) - cassert (b0 = b1) meta "Variable bindings *must* be in the prefix and consequently their - ids must be the same"; + cassert (b0 = b1) meta + "Variable bindings *must* be in the prefix and consequently their\n\ + \ ids must be the same"; (* Match the values *) let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in @@ -503,8 +518,11 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c log#ldebug (lazy ("join_prefixes: Abs:\n\n- fixed_ids:\n" ^ "\n" - ^ show_ids_sets fixed_ids ^ "\n\n- abs0:\n" ^ abs_to_string meta ctx0 abs0 - ^ "\n\n- abs1:\n" ^ abs_to_string meta ctx1 abs1 ^ "\n\n")); + ^ show_ids_sets fixed_ids ^ "\n\n- abs0:\n" + ^ abs_to_string meta ctx0 abs0 + ^ "\n\n- abs1:\n" + ^ abs_to_string meta ctx1 abs1 + ^ "\n\n")); (* Same as for the dummy values: there are two cases *) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( @@ -599,7 +617,8 @@ let destructure_new_abs (meta : Meta.meta) (loop_id : LoopId.id) (fun abs -> if is_fresh_abs_id abs.abs_id then let abs = - destructure_abs meta abs_kind can_end destructure_shared_values ctx abs + destructure_abs meta abs_kind can_end destructure_shared_values ctx + abs in abs else abs) @@ -638,9 +657,9 @@ let refresh_abs (old_abs : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = in { ctx with env } -let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (loop_id : LoopId.id) - (fixed_ids : ids_sets) (old_ctx : eval_ctx) (ctxl : eval_ctx list) : - (eval_ctx * eval_ctx list) * eval_ctx = +let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) + (loop_id : LoopId.id) (fixed_ids : ids_sets) (old_ctx : eval_ctx) + (ctxl : eval_ctx list) : (eval_ctx * eval_ctx list) * eval_ctx = (* # Join with the new contexts, one by one For every context, we repeteadly attempt to join it with the current @@ -671,21 +690,21 @@ let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: initial ctx:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Destructure the abstractions introduced in the new context *) let ctx = destructure_new_abs meta loop_id fixed_ids.aids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after destructure:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Collapse the context we want to add to the join *) let ctx = collapse_ctx meta loop_id None fixed_ids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after collapse:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Refresh the fresh abstractions *) let ctx = refresh_abs fixed_ids.aids ctx in @@ -695,7 +714,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after join:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx1)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx1)); (* Collapse again - the join might have introduce abstractions we want to merge with the others (note that those abstractions may actually diff --git a/compiler/InterpreterLoopsJoinCtxs.mli b/compiler/InterpreterLoopsJoinCtxs.mli index d92b3750..0e84657c 100644 --- a/compiler/InterpreterLoopsJoinCtxs.mli +++ b/compiler/InterpreterLoopsJoinCtxs.mli @@ -85,7 +85,8 @@ val merge_into_abstraction : - [ctx0] - [ctx1] *) -val join_ctxs : Meta.meta -> loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update +val join_ctxs : + Meta.meta -> loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update (** Join the context at the entry of the loop with the contexts upon reentry (upon reaching the [Continue] statement - the goal is to compute a fixed diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 24e588f2..1a6e6926 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -43,8 +43,9 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) match Id0.Map.find_opt id0 !map with | None -> () | Some set -> - sanity_check ( - (not check_not_already_registered) || not (Id1.Set.mem id1 set)) meta); + sanity_check + ((not check_not_already_registered) || not (Id1.Set.mem id1 set)) + meta); (* Update the mapping *) map := Id0.Map.update id0 @@ -54,9 +55,10 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) | Some ids -> (* Sanity check *) sanity_check (not check_singleton_sets) meta; - sanity_check ( - (not check_not_already_registered) - || not (Id1.Set.mem id1 ids)) meta; + sanity_check + ((not check_not_already_registered) + || not (Id1.Set.mem id1 ids)) + meta; (* Update *) Some (Id1.Set.add id1 ids)) !map @@ -107,8 +109,7 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) -> (* Ignore the id of the borrow, if there is *) self#visit_typed_avalue abs_id child - | AEndedMutBorrow _ | AEndedSharedBorrow -> - craise meta "Unreachable" + | AEndedMutBorrow _ | AEndedSharedBorrow -> craise meta "Unreachable" method! visit_borrow_id abs_id bid = register_borrow_id abs_id bid method! visit_loan_id abs_id lid = register_loan_id abs_id lid @@ -185,6 +186,7 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) module MakeMatcher (M : PrimMatcher) : Matcher = struct let meta = M.meta + let rec match_typed_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) (v0 : typed_value) (v1 : typed_value) : typed_value = let match_rec = match_typed_values ctx0 ctx1 in @@ -227,10 +229,11 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> let bv = match_rec bv0 bv1 in - cassert ( - not - (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos - bv.value)) M.meta "TODO: error message"; + cassert + (not + (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos + bv.value)) + M.meta "TODO: error message"; let bid, bv = M.match_mut_borrows ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv in @@ -253,7 +256,9 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (lc0, lc1) with | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in - cassert (not (value_has_borrows sv.value)) M.meta "TODO: error message"; + cassert + (not (value_has_borrows sv.value)) + M.meta "TODO: error message"; let ids, sv = M.match_shared_loans ctx0 ctx1 ty ids0 ids1 sv in VSharedLoan (ids, sv) | VMutLoan id0, VMutLoan id1 -> @@ -266,8 +271,16 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | VSymbolic sv0, VSymbolic sv1 -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - cassert (not (value_has_borrows v0.value)) M.meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; - cassert (not (value_has_borrows v1.value)) M.meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; + cassert + (not (value_has_borrows v0.value)) + M.meta + "Nested borrows are not supported yet and all the symbolic values \ + containing borrows are currently forced to be eagerly expanded"; + cassert + (not (value_has_borrows v1.value)) + M.meta + "Nested borrows are not supported yet and all the symbolic values \ + containing borrows are currently forced to be eagerly expanded"; (* Match *) let sv = M.match_symbolic_values ctx0 ctx1 sv0 sv1 in { v1 with value = VSymbolic sv } @@ -401,25 +414,25 @@ end module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (** Small utility *) let meta = S.meta - let push_abs (abs : abs) : unit = S.nabs := abs :: !S.nabs + let push_abs (abs : abs) : unit = S.nabs := abs :: !S.nabs let push_absl (absl : abs list) : unit = List.iter push_abs absl - let match_etys _ _ ty0 ty1 = + let match_etys _ _ ty0 ty1 = sanity_check (ty0 = ty1) meta; ty0 - let match_rtys _ _ ty0 ty1 = + let match_rtys _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) sanity_check (ty0 = ty1) meta; ty0 - let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_distinct_adts (ctx0 : eval_ctx) (ctx1 : eval_ctx) (ty : ety) + let match_distinct_adts (ctx0 : eval_ctx) (ctx1 : eval_ctx) (ty : ety) (adt0 : adt_value) (adt1 : adt_value) : typed_value = (* Check that the ADTs don't contain borrows - this is redundant with checks performed by the caller, but we prefer to be safe with regards to future @@ -454,7 +467,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* No borrows, no loans, no bottoms: we can introduce a symbolic value *) mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) match_rec + let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) match_rec (ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = (* Lookup the shared values and match them - we do this mostly to make sure we end loans which might appear on one side @@ -510,7 +523,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) bid2 - let match_mut_borrows (ctx0 : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_mut_borrows (ctx0 : eval_ctx) (_ : eval_ctx) (ty : ety) (bid0 : borrow_id) (bv0 : typed_value) (bid1 : borrow_id) (bv1 : typed_value) (bv : typed_value) : borrow_id * typed_value = if bid0 = bid1 then ( @@ -561,8 +574,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct do so, we won't introduce reborrows like above: the forward loop function will update [v], while the backward loop function will return nothing. *) - cassert ( - not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) meta "Nested borrows are not supported yet"; + cassert + (not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) + meta "Nested borrows are not supported yet"; if bv0 = bv1 then ( sanity_check (bv0 = bv) meta; @@ -626,7 +640,8 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = let bv_ty = bv.ty in - cassert (ty_no_regions bv_ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions bv_ty) meta + "Nested borrows are not supported yet"; let value = ABorrow (AMutBorrow (bid, mk_aignored meta bv_ty)) in { value; ty = borrow_ty } in @@ -656,7 +671,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) (bid2, sv) - let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) + let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) (sv : typed_value) : loan_id_set * typed_value = (* Check if the ids are the same - Rem.: we forbid the sets of loans @@ -687,7 +702,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct both borrows *) raise (ValueMatchFailure (LoanInLeft id0)) - let match_symbolic_values (ctx0 : eval_ctx) (_ : eval_ctx) + let match_symbolic_values (ctx0 : eval_ctx) (_ : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -699,11 +714,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct else ( (* The caller should have checked that the symbolic values don't contain borrows *) - sanity_check (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)) meta; + sanity_check + (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)) + meta; (* We simply introduce a fresh symbolic value *) mk_fresh_symbolic_value meta sv0.sv_ty) - let match_symbolic_with_other (ctx0 : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (ctx0 : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = (* Check that: - there are no borrows in the symbolic value @@ -711,14 +728,20 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct If there are loans in the regular value, raise an exception. *) let type_infos = ctx0.type_ctx.type_infos in - cassert (not (ty_has_borrows type_infos sv.sv_ty)) meta "Check that: - - there are no borrows in the symbolic value - - there are no borrows in the \"regular\" value - If there are loans in the regular value, raise an exception."; - cassert (not (ValuesUtils.value_has_borrows type_infos v.value)) meta "Check that: - - there are no borrows in the symbolic value - - there are no borrows in the \"regular\" value - If there are loans in the regular value, raise an exception."; + cassert + (not (ty_has_borrows type_infos sv.sv_ty)) + meta + "Check that:\n\ + \ - there are no borrows in the symbolic value\n\ + \ - there are no borrows in the \"regular\" value\n\ + \ If there are loans in the regular value, raise an exception."; + cassert + (not (ValuesUtils.value_has_borrows type_infos v.value)) + meta + "Check that:\n\ + \ - there are no borrows in the symbolic value\n\ + \ - there are no borrows in the \"regular\" value\n\ + \ If there are loans in the regular value, raise an exception."; let value_is_left = not left in (match InterpreterBorrowsCore.get_first_loan_in_value v with | None -> () @@ -731,7 +754,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return a fresh symbolic value *) mk_fresh_symbolic_typed_value meta sv.sv_ty - let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) + let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) (v : typed_value) : typed_value = (* If there are outer loans in the non-bottom value, raise an exception. Otherwise, convert it to an abstraction and return [Bottom]. @@ -775,10 +798,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let match_distinct_aadts _ _ _ _ _ _ _ = craise meta "Unreachable" let match_ashared_borrows _ _ _ _ _ _ = craise meta "Unreachable" let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = - craise meta "Unreachable" - + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" let match_avalues _ _ _ _ = craise meta "Unreachable" end @@ -790,6 +810,7 @@ module type MatchMoveState = sig (** The moved values *) val nvalues : typed_value list ref + val meta : Meta.meta end @@ -812,13 +833,14 @@ end module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (** Small utility *) let meta = S.meta + let push_moved_value (v : typed_value) : unit = S.nvalues := v :: !S.nvalues - let match_etys _ _ ty0 ty1 = + let match_etys _ _ ty0 ty1 = sanity_check (ty0 = ty1) meta; ty0 - let match_rtys _ _ ty0 ty1 = + let match_rtys _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) sanity_check (ty0 = ty1) meta; @@ -863,7 +885,7 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (sv : symbolic_value) (v : typed_value) : typed_value = if left then v else mk_typed_value_from_symbolic_value sv - let match_bottom_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_bottom_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) (v : typed_value) : typed_value = let with_borrows = false in if left then ( @@ -898,18 +920,16 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct let match_distinct_aadts _ _ _ _ _ _ _ = craise meta "Unreachable" let match_ashared_borrows _ _ _ _ _ _ = craise meta "Unreachable" let match_amut_borrows _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = - craise meta "Unreachable" - - let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_avalues _ _ _ _ = craise meta "Unreachable" + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_avalues _ _ _ _ = craise meta "Unreachable" end module MakeCheckEquivMatcher (S : MatchCheckEquivState) : CheckEquivMatcher = struct module MkGetSetM (Id : Identifiers.Id) = struct module Inj = Id.InjSubst + let add (msg : string) (m : Inj.t ref) (k0 : Id.id) (k1 : Id.id) = (* Check if k0 is already registered as a key *) match Inj.find_opt k0 !m with @@ -948,7 +968,9 @@ struct Id.Set.of_list (match_el msg m (Id.Set.elements ks0) (Id.Set.elements ks1)) end + let meta = S.meta + module GetSetRid = MkGetSetM (RegionId) let match_rid = GetSetRid.match_e "match_rid: " S.rid_map @@ -995,7 +1017,7 @@ struct let match_etys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = if ty0 <> ty1 then raise (Distinct "match_etys") else ty0 - let match_rtys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = + let match_rtys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = let match_distinct_types _ _ = raise (Distinct "match_rtys") in let match_regions r0 r1 = match (r0, r1) with @@ -1007,7 +1029,7 @@ struct in match_types meta match_distinct_types match_regions ty0 ty1 - let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty @@ -1015,7 +1037,7 @@ struct (_adt0 : adt_value) (_adt1 : adt_value) : typed_value = raise (Distinct "match_distinct_adts") - let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) (match_typed_values : typed_value -> typed_value -> typed_value) (_ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = log#ldebug @@ -1061,7 +1083,7 @@ struct (bid1 : loan_id) : loan_id = match_loan_id bid0 bid1 - let match_symbolic_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_symbolic_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -1085,7 +1107,9 @@ struct sv else ( (* Check: fixed values are fixed *) - sanity_check (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)) meta; + sanity_check + (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)) + meta; (* Update the symbolic value mapping *) let sv1 = mk_typed_value_from_symbolic_value sv1 in @@ -1098,7 +1122,7 @@ struct we want *) sv0) - let match_symbolic_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( @@ -1112,7 +1136,7 @@ struct (* Return - the returned value is not used, so we can return whatever we want *) v) - let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) + let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) (v : typed_value) : typed_value = (* It can happen that some variables get initialized in some branches and not in some others, which causes problems when matching. *) @@ -1121,7 +1145,8 @@ struct a continue, where the fixed point contains some bottom values. *) let value_is_left = not left in let ctx = if value_is_left then ctx0 else ctx1 in - if left && not (value_has_loans_or_borrows ctx v.value) then mk_bottom meta v.ty + if left && not (value_has_loans_or_borrows ctx v.value) then + mk_bottom meta v.ty else raise (Distinct @@ -1150,7 +1175,7 @@ struct let value = ALoan (ASharedLoan (bids, v, av)) in { value; ty } - let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 + let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 id1 _av1 ty av = log#ldebug (lazy @@ -1163,7 +1188,7 @@ struct let value = ALoan (AMutLoan (id, av)) in { value; ty } - let match_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = + let match_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = log#ldebug (lazy ("avalues don't match:\n- v0: " @@ -1313,22 +1338,25 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) ^ "\n- aid_map: " ^ AbstractionId.InjSubst.show_t !aid_map ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx0 with env = List.rev env0 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) + { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx1 with env = List.rev env1 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) + { ctx1 with env = List.rev env1 } ^ "\n\n")); match (env0, env1) with | EBinding (BDummy b0, v0) :: env0', EBinding (BDummy b1, v1) :: env1' -> (* Sanity check: if the dummy value is an old value, the bindings must be the same and their values equal (and the borrows/loans/symbolic *) - if DummyVarId.Set.mem b0 fixed_ids.dids then ( - (* Fixed values: the values must be equal *) - sanity_check (b0 = b1) meta; - sanity_check (v0 = v1) meta; - (* The ids present in the left value must be fixed *) - let ids, _ = compute_typed_value_ids v0 in - sanity_check ((not S.check_equiv) || ids_are_fixed ids)) meta; + if DummyVarId.Set.mem b0 fixed_ids.dids then + ((* Fixed values: the values must be equal *) + sanity_check (b0 = b1) meta; + sanity_check (v0 = v1) meta; + (* The ids present in the left value must be fixed *) + let ids, _ = compute_typed_value_ids v0 in + sanity_check ((not S.check_equiv) || ids_are_fixed ids)) + meta; (* We still match the values - allows to compute mappings (which are the identity actually) *) let _ = M.match_typed_values ctx0 ctx1 v0 v1 in @@ -1396,24 +1424,25 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) log#ldebug (lazy ("match_ctxs: distinct: " ^ msg)); None -let ctxs_are_equivalent (meta : Meta.meta) (fixed_ids : ids_sets) (ctx0 : eval_ctx) - (ctx1 : eval_ctx) : bool = +let ctxs_are_equivalent (meta : Meta.meta) (fixed_ids : ids_sets) + (ctx0 : eval_ctx) (ctx1 : eval_ctx) : bool = let check_equivalent = true in let lookup_shared_value _ = craise meta "Unreachable" in Option.is_some (match_ctxs meta check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx0 ctx1) -let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId.id) - (fixed_ids : ids_sets) (src_ctx : eval_ctx) : cm_fun = +let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) + (loop_id : LoopId.id) (fixed_ids : ids_sets) (src_ctx : eval_ctx) : cm_fun = fun cf tgt_ctx -> (* Debug *) log#ldebug (lazy ("prepare_match_ctx_with_target:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- src_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n- tgt_ctx: " ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx - )); + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n- tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); (* End the loans which lead to mismatches when joining *) let rec cf_reorganize_join_tgt : cm_fun = fun cf tgt_ctx -> @@ -1526,8 +1555,9 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (lazy ("cf_reorganize_join_tgt: done with borrows/loans and moves:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- src_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n- tgt_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n- tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); cf tgt_ctx with ValueMatchFailure e -> @@ -1544,8 +1574,9 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (* Apply the reorganization *) cf_reorganize_join_tgt cf tgt_ctx -let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId.id) - (is_loop_entry : bool) (fp_bl_maps : borrow_loan_corresp) +let match_ctx_with_target (config : config) (meta : Meta.meta) + (loop_id : LoopId.id) (is_loop_entry : bool) + (fp_bl_maps : borrow_loan_corresp) (fp_input_svalues : SymbolicValueId.id list) (fixed_ids : ids_sets) (src_ctx : eval_ctx) : st_cm_fun = fun cf tgt_ctx -> @@ -1628,8 +1659,10 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs:" ^ "\n\n- src_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n\n- tgt_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx ^ "\n\n- filt_tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n\n- tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx + ^ "\n\n- filt_tgt_ctx: " ^ eval_ctx_to_string_no_filter ~meta:(Some meta) filt_tgt_ctx ^ "\n\n- filt_src_ctx: " ^ eval_ctx_to_string_no_filter ~meta:(Some meta) filt_src_ctx @@ -1801,8 +1834,9 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId (* No mapping: this means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) and because of this, it should actually be mapped to itself *) - sanity_check ( - BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id) meta; + sanity_check + (BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id) + meta; id | Some id -> id @@ -1833,7 +1867,8 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: done:\n\ - - result ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); + - result ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); (* Sanity check *) if !Config.sanity_checks then diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 93ce0515..c386c2db 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -69,7 +69,8 @@ type projection_access = { TODO: use exceptions? *) -let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : eval_ctx) +let rec access_projection (meta : Meta.meta) (access : projection_access) + (ctx : eval_ctx) (* Function to (eventually) update the value we find *) (update : typed_value -> typed_value) (p : projection) (v : typed_value) : (eval_ctx * updated_read_value) path_access_result = @@ -86,10 +87,9 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : (lazy ("Not the same type:\n- nv.ty: " ^ show_ety nv.ty ^ "\n- v.ty: " ^ show_ety v.ty)); - craise - meta - "Assertion failed: new value doesn't have the same type as its \ - destination"); + craise meta + "Assertion failed: new value doesn't have the same type as its \ + destination"); Ok (ctx, { read = v; updated = nv }) | pe :: p' -> ( (* Match on the projection element and the value *) @@ -232,7 +232,9 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : to the fact that we need to reexplore the *whole* place (i.e, we mustn't ignore the current projection element *) if access.enter_shared_loans then - match access_projection meta access ctx update (pe :: p') sv with + match + access_projection meta access ctx update (pe :: p') sv + with | Error err -> Error err | Ok (ctx, res) -> let nv = @@ -301,8 +303,8 @@ let access_kind_to_projection_access (access : access_kind) : projection_access Note that we only access the value at the place, and do not check that the value is "well-formed" (for instance that it doesn't contain bottoms). *) -let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : eval_ctx) : - typed_value path_access_result = +let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) + (ctx : eval_ctx) : typed_value path_access_result = let access = access_kind_to_projection_access access in (* The update function is the identity *) let update v = v in @@ -322,15 +324,15 @@ let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : craise meta "Unexpected environment update"); Ok read_value -let read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value - = +let read_place (meta : Meta.meta) (access : access_kind) (p : place) + (ctx : eval_ctx) : typed_value = match try_read_place meta access p ctx with | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) | Ok v -> v (** Attempt to update the value at a given place *) -let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : typed_value) - (ctx : eval_ctx) : eval_ctx path_access_result = +let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) + (nv : typed_value) (ctx : eval_ctx) : eval_ctx path_access_result = let access = access_kind_to_projection_access access in (* The update function substitutes the value with the new value *) let update _ = nv in @@ -340,26 +342,28 @@ let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : (* We ignore the read value *) Ok ctx -let write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : typed_value) - (ctx : eval_ctx) : eval_ctx = +let write_place (meta : Meta.meta) (access : access_kind) (p : place) + (nv : typed_value) (ctx : eval_ctx) : eval_ctx = match try_write_place meta access p nv ctx with | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) | Ok ctx -> ctx -let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) - (opt_variant_id : VariantId.id option) (generics : generic_args) : - typed_value = +let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) + (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) + (generics : generic_args) : typed_value = sanity_check (TypesUtils.generic_args_only_erased_regions generics) meta; (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) let def = ctx_lookup_type_decl ctx def_id in - sanity_check (List.length generics.regions = List.length def.generics.regions) meta; + sanity_check + (List.length generics.regions = List.length def.generics.regions) + meta; (* Compute the field types *) let field_types = - AssociatedTypes.type_decl_get_inst_norm_field_etypes meta ctx def opt_variant_id - generics + AssociatedTypes.type_decl_get_inst_norm_field_etypes meta ctx def + opt_variant_id generics in (* Initialize the expanded value *) let fields = List.map (mk_bottom meta) field_types in @@ -367,7 +371,8 @@ let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_i let ty = TAdt (TAdtId def_id, generics) in { value = av; ty } -let compute_expanded_bottom_tuple_value (meta : Meta.meta) (field_types : ety list) : typed_value = +let compute_expanded_bottom_tuple_value (meta : Meta.meta) + (field_types : ety list) : typed_value = (* Generate the field values *) let fields = List.map (mk_bottom meta) field_types in let v = VAdt { variant_id = None; field_values = fields } in @@ -396,9 +401,9 @@ let compute_expanded_bottom_tuple_value (meta : Meta.meta) (field_types : ety li about which variant we should project to, which is why we *can* set the variant index when writing one of its fields). *) -let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind) (p : place) - (remaining_pes : int) (pe : projection_elem) (ty : ety) (ctx : eval_ctx) : - eval_ctx = +let expand_bottom_value_from_projection (meta : Meta.meta) + (access : access_kind) (p : place) (remaining_pes : int) + (pe : projection_elem) (ty : ety) (ctx : eval_ctx) : eval_ctx = (* Debugging *) log#ldebug (lazy @@ -426,7 +431,8 @@ let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind | ( Field (ProjAdt (def_id, opt_variant_id), _), TAdt (TAdtId def_id', generics) ) -> sanity_check (def_id = def_id') meta; - compute_expanded_bottom_adt_value meta ctx def_id opt_variant_id generics + compute_expanded_bottom_adt_value meta ctx def_id opt_variant_id + generics (* Tuples *) | ( Field (ProjTuple arity, _), TAdt @@ -436,17 +442,16 @@ let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind (* Generate the field values *) compute_expanded_bottom_tuple_value meta types | _ -> - craise - meta - ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty) + craise meta + ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty) in (* Update the context by inserting the expanded value at the proper place *) match try_write_place meta access p' nv ctx with | Ok ctx -> ctx | Error _ -> craise meta "Unreachable" -let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (access : access_kind) - (p : place) : cm_fun = +let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Attempt to read the place: if it fails, update the environment and retry *) match try_read_place meta access p ctx with @@ -456,7 +461,8 @@ let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (access match err with | FailSharedLoan bids -> end_borrows config meta bids | FailMutLoan bid -> end_borrow config meta bid - | FailReservedMutBorrow bid -> promote_reserved_mut_borrow config meta bid + | FailReservedMutBorrow bid -> + promote_reserved_mut_borrow config meta bid | FailSymbolic (i, sp) -> (* Expand the symbolic value *) let proj, _ = @@ -473,8 +479,8 @@ let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (access in comp cc (update_ctx_along_read_place config meta access p) cf ctx -let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (access : access_kind) - (p : place) : cm_fun = +let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Attempt to *read* (yes, *read*: we check the access to the place, and write to it later) the place: if it fails, update the environment and retry *) @@ -486,7 +492,8 @@ let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (acces match err with | FailSharedLoan bids -> end_borrows config meta bids | FailMutLoan bid -> end_borrow config meta bid - | FailReservedMutBorrow bid -> promote_reserved_mut_borrow config meta bid + | FailReservedMutBorrow bid -> + promote_reserved_mut_borrow config meta bid | FailSymbolic (_pe, sp) -> (* Expand the symbolic value *) expand_symbolic_value_no_branching config meta sp @@ -495,8 +502,8 @@ let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (acces (* Expand the {!Bottom} value *) fun cf ctx -> let ctx = - expand_bottom_value_from_projection meta access p remaining_pes pe ty - ctx + expand_bottom_value_from_projection meta access p remaining_pes + pe ty ctx in cf ctx | FailBorrow _ -> craise meta "Could not write to a borrow" @@ -507,8 +514,8 @@ let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (acces (** Small utility used to break control-flow *) exception UpdateCtx of cm_fun -let rec end_loans_at_place (config : config) (meta : Meta.meta) (access : access_kind) (p : place) - : cm_fun = +let rec end_loans_at_place (config : config) (meta : Meta.meta) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Iterator to explore a value and update the context whenever we find * loans. @@ -562,7 +569,8 @@ let rec end_loans_at_place (config : config) (meta : Meta.meta) (access : access * a recursive call to reinspect the value *) comp cc (end_loans_at_place config meta access p) cf ctx -let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) : cm_fun = +let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) + : cm_fun = fun cf ctx -> (* Move the current value in the place outside of this place and into * a dummy variable *) @@ -610,13 +618,14 @@ let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) (* Continue *) cc cf ctx -let prepare_lplace (config : config) (meta : Meta.meta) (p : place) (cf : typed_value -> m_fun) : - m_fun = +let prepare_lplace (config : config) (meta : Meta.meta) (p : place) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> log#ldebug (lazy ("prepare_lplace:" ^ "\n- p: " ^ place_to_string ctx p - ^ "\n- Initial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ "\n- Initial context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Access the place *) let access = Write in let cc = update_ctx_along_write_place config meta access p in diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index f1c481ca..260f07bf 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -13,13 +13,15 @@ type access_kind = Read | Write | Move updates the environment (by ending borrows, expanding symbolic values, etc.) until it manages to fully access the provided place. *) -val update_ctx_along_read_place : config -> Meta.meta -> access_kind -> place -> cm_fun +val update_ctx_along_read_place : + config -> Meta.meta -> access_kind -> place -> cm_fun (** Update the environment to be able to write to a place. See {!update_ctx_along_read_place}. *) -val update_ctx_along_write_place : config -> Meta.meta -> access_kind -> place -> cm_fun +val update_ctx_along_write_place : + config -> Meta.meta -> access_kind -> place -> cm_fun (** Read the value at a given place. @@ -40,7 +42,8 @@ val read_place : Meta.meta -> access_kind -> place -> eval_ctx -> typed_value the overwritten value contains borrows, loans, etc. and will simply overwrite it. *) -val write_place : Meta.meta -> access_kind -> place -> typed_value -> eval_ctx -> eval_ctx +val write_place : + Meta.meta -> access_kind -> place -> typed_value -> eval_ctx -> eval_ctx (** Compute an expanded tuple ⊥ value. @@ -96,4 +99,5 @@ val end_loans_at_place : config -> Meta.meta -> access_kind -> place -> cm_fun place. This value should not contain any outer loan (and we check it is the case). Note that this value is very likely to contain ⊥ subvalues. *) -val prepare_lplace : config -> Meta.meta -> place -> (typed_value -> m_fun) -> m_fun +val prepare_lplace : + config -> Meta.meta -> place -> (typed_value -> m_fun) -> m_fun diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 809303ae..f8f99584 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -27,7 +27,8 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id generics + Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id + generics in (* Project over the field values *) @@ -35,8 +36,8 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) let proj_fields = List.map (fun (fv, fty) -> - apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions fv - fty) + apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow + regions fv fty) fields_types in List.concat proj_fields @@ -49,8 +50,8 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let asb = - apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions - bv ref_ty + apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow + regions bv ref_ty in (bid, asb) | VSharedBorrow bid, RShared -> @@ -67,9 +68,8 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) in (bid, asb) | VReservedMutBorrow _, _ -> - craise - meta - "Can't apply a proj_borrow over a reserved mutable borrow" + craise meta + "Can't apply a proj_borrow over a reserved mutable borrow" | _ -> craise meta "Unreachable" in let asb = @@ -84,14 +84,17 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VLoan _, _ -> craise meta "Unreachable" | VSymbolic s, _ -> (* Check that the projection doesn't contain ended regions *) - sanity_check (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) meta; + sanity_check + (not + (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) + meta; [ AsbProjReborrows (s, ty) ] | _ -> craise meta "Unreachable" -let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) (ctx : eval_ctx) - (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t) - (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : - typed_avalue = +let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) + (ctx : eval_ctx) (fresh_reborrow : BorrowId.id -> BorrowId.id) + (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) + (v : typed_value) (ty : rty) : typed_avalue = (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Substitute.erase_regions ty in @@ -105,15 +108,16 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id generics + Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id + generics in (* Project over the field values *) let fields_types = List.combine adt.field_values field_types in let proj_fields = List.map (fun (fv, fty) -> - apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions fv fty) + apply_proj_borrows meta check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions fv fty) fields_types in AAdt { variant_id = adt.variant_id; field_values = proj_fields } @@ -148,10 +152,8 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( *) ASharedBorrow bid | VReservedMutBorrow _, _ -> - craise - meta - "Can't apply a proj_borrow over a reserved mutable \ - borrow" + craise meta + "Can't apply a proj_borrow over a reserved mutable borrow" | _ -> craise meta "Unreachable" in ABorrow bc @@ -182,16 +184,14 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( match sv with | _, Concrete (VSharedLoan (_, sv)) | _, Abstract (ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow - regions sv ref_ty + apply_proj_borrows_on_shared_borrow meta ctx + fresh_reborrow regions sv ref_ty | _ -> craise meta "Unexpected" in AProjSharedBorrow asb | VReservedMutBorrow _, _ -> - craise - meta - "Can't apply a proj_borrow over a reserved mutable \ - borrow" + craise meta + "Can't apply a proj_borrow over a reserved mutable borrow" | _ -> craise meta "Unreachable" in ABorrow bc @@ -199,20 +199,21 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( | VSymbolic s, _ -> (* Check that the projection doesn't contain already ended regions, * if necessary *) - if check_symbolic_no_ended then ( - let ty1 = s.sv_ty in - let rset1 = ctx.ended_regions in - let ty2 = ty in - let rset2 = regions in - log#ldebug - (lazy - ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1 - ^ "\n- rset1: " - ^ RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " - ^ RegionId.Set.to_string None rset2 - ^ "\n")); - sanity_check (not (projections_intersect meta ty1 rset1 ty2 rset2))) meta; + if check_symbolic_no_ended then + (let ty1 = s.sv_ty in + let rset1 = ctx.ended_regions in + let ty2 = ty in + let rset2 = regions in + log#ldebug + (lazy + ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1 + ^ "\n- rset1: " + ^ RegionId.Set.to_string None rset1 + ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " + ^ RegionId.Set.to_string None rset2 + ^ "\n")); + sanity_check (not (projections_intersect meta ty1 rset1 ty2 rset2))) + meta; ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror @@ -224,8 +225,8 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( in { value; ty } -let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) (sv : symbolic_value) - (see : symbolic_expansion) : typed_value = +let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) + (sv : symbolic_value) (see : symbolic_expansion) : typed_value = let ty = Subst.erase_regions sv.sv_ty in let value = match see with @@ -240,8 +241,8 @@ let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) (sv : symbolic_val in { value; ty } -let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) (sv : symbolic_value) - (see : symbolic_expansion) : typed_value = +let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) + (sv : symbolic_value) (see : symbolic_expansion) : typed_value = match see with | SeMutRef (bid, bv) -> let ty = Subst.erase_regions sv.sv_ty in @@ -256,9 +257,9 @@ let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) (sv : symbo TODO: detailed comments. See [apply_proj_borrows] *) -let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionId.Set.t) - (ancestors_regions : RegionId.Set.t) (see : symbolic_expansion) - (original_sv_ty : rty) : typed_avalue = +let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) + (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) + (see : symbolic_expansion) (original_sv_ty : rty) : typed_avalue = (* Sanity check: if we have a proj_loans over a symbolic value, it should * contain regions which we will project *) sanity_check (ty_has_regions_in_set regions original_sv_ty) meta; @@ -332,8 +333,8 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI borrows - easy - and mutable borrows - in this case, we reborrow the whole borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]). *) -let apply_reborrows (meta : Meta.meta) (reborrows : (BorrowId.id * BorrowId.id) list) - (ctx : eval_ctx) : eval_ctx = +let apply_reborrows (meta : Meta.meta) + (reborrows : (BorrowId.id * BorrowId.id) list) (ctx : eval_ctx) : eval_ctx = (* This is a bit brutal, but whenever we insert a reborrow, we remove * it from the list. This allows us to check that all the reborrows were * applied before returning. @@ -468,7 +469,8 @@ let apply_reborrows (meta : Meta.meta) (reborrows : (BorrowId.id * BorrowId.id) (* Return *) ctx -let prepare_reborrows (config : config) (meta : Meta.meta) (allow_reborrows : bool) : +let prepare_reborrows (config : config) (meta : Meta.meta) + (allow_reborrows : bool) : (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) = let reborrows : (BorrowId.id * BorrowId.id) list ref = ref [] in (* The function to generate and register fresh reborrows *) @@ -492,9 +494,10 @@ let prepare_reborrows (config : config) (meta : Meta.meta) (allow_reborrows : bo (fresh_reborrow, apply_registered_reborrows) (** [ty] shouldn't have erased regions *) -let apply_proj_borrows_on_input_value (config : config) (meta : Meta.meta) (ctx : eval_ctx) - (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) - (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = +let apply_proj_borrows_on_input_value (config : config) (meta : Meta.meta) + (ctx : eval_ctx) (regions : RegionId.Set.t) + (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : + eval_ctx * typed_avalue = cassert (ty_is_rty ty) meta "TODO: error message"; let check_symbolic_no_ended = true in let allow_reborrows = true in diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index 64ad1b29..17569ac8 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -15,7 +15,12 @@ open Contexts [original_sv_ty]: shouldn't have erased regions *) val apply_proj_loans_on_symbolic_expansion : - Meta.meta -> RegionId.Set.t -> RegionId.Set.t -> symbolic_expansion -> rty -> typed_avalue + Meta.meta -> + RegionId.Set.t -> + RegionId.Set.t -> + symbolic_expansion -> + rty -> + typed_avalue (** Convert a symbolic expansion *which is not a borrow* to a value *) val symbolic_expansion_non_borrow_to_value : @@ -28,7 +33,7 @@ val symbolic_expansion_non_borrow_to_value : during a symbolic expansion. *) val symbolic_expansion_non_shared_borrow_to_value : - Meta.meta -> symbolic_value -> symbolic_expansion -> typed_value + Meta.meta -> symbolic_value -> symbolic_expansion -> typed_value (** Auxiliary function to prepare reborrowing operations (used when applying projectors). @@ -43,7 +48,10 @@ val symbolic_expansion_non_shared_borrow_to_value : - [allow_reborrows] *) val prepare_reborrows : - config -> Meta.meta -> bool -> (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) + config -> + Meta.meta -> + bool -> + (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) (** Apply (and reduce) a projector over borrows to an avalue. We use this for instance to spread the borrows present in the inputs diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index a872f24a..fa7bbc51 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -24,7 +24,7 @@ let drop_value (config : config) (meta : Meta.meta) (p : place) : cm_fun = log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Note that we use [Write], not [Move]: we allow to drop values *below* borrows *) let access = Write in (* First make sure we can access the place, by ending loans or expanding @@ -45,7 +45,7 @@ let drop_value (config : config) (meta : Meta.meta) (p : place) : cm_fun = log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); cf ctx in (* Compose and apply *) @@ -58,7 +58,8 @@ let push_dummy_var (vid : DummyVarId.id) (v : typed_value) : cm_fun = cf ctx (** Remove a dummy variable from the environment *) -let remove_dummy_var (meta : Meta.meta) (vid : DummyVarId.id) (cf : typed_value -> m_fun) : m_fun = +let remove_dummy_var (meta : Meta.meta) (vid : DummyVarId.id) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> let ctx, v = ctx_remove_dummy_var meta ctx vid in cf v ctx @@ -94,7 +95,8 @@ let push_vars (meta : Meta.meta) (vars : (var * typed_value) list) : cm_fun = dummy variable and putting in its destination (after having checked that preparing the destination didn't introduce ⊥). *) -let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : place) : cm_fun = +let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) + (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -119,7 +121,9 @@ let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : let ctx = ctx_push_dummy_var ctx dest_vid mv in (* Write to the destination *) (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) - exec_assert (not (bottom_in_value ctx.ended_regions rv)) meta "The value to move contains bottom"; + exec_assert + (not (bottom_in_value ctx.ended_regions rv)) + meta "The value to move contains bottom"; (* Update the destination *) let ctx = write_place meta Write p rv ctx in (* Debug *) @@ -136,8 +140,8 @@ let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : comp cc move_dest cf ctx (** Evaluate an assertion, when the scrutinee is not symbolic *) -let eval_assertion_concrete (config : config) (meta : Meta.meta) (assertion : assertion) : - st_cm_fun = +let eval_assertion_concrete (config : config) (meta : Meta.meta) + (assertion : assertion) : st_cm_fun = fun cf ctx -> (* There won't be any symbolic expansions: fully evaluate the operand *) let eval_op = eval_operand config meta assertion.cond in @@ -148,8 +152,9 @@ let eval_assertion_concrete (config : config) (meta : Meta.meta) (assertion : as (* Branch *) if b = assertion.expected then cf Unit ctx else cf Panic ctx | _ -> - craise - meta ("Expected a boolean, got: " ^ typed_value_to_string ~meta:(Some meta) ctx v) + craise meta + ("Expected a boolean, got: " + ^ typed_value_to_string ~meta:(Some meta) ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -160,7 +165,8 @@ let eval_assertion_concrete (config : config) (meta : Meta.meta) (assertion : as a call to [assert ...] then continue in the success branch (and thus expand the boolean to [true]). *) -let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) : st_cm_fun = +let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) + : st_cm_fun = fun cf ctx -> (* Evaluate the operand *) let eval_op = eval_operand config meta assertion.cond in @@ -178,23 +184,24 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) (* Delegate to the concrete evaluation function *) eval_assertion_concrete config meta assertion cf ctx | VSymbolic sv -> - sanity_check(config.mode = SymbolicMode) meta; + sanity_check (config.mode = SymbolicMode) meta; sanity_check (sv.sv_ty = TLiteral TBool) meta; (* We continue the execution as if the test had succeeded, and thus * perform the symbolic expansion: sv ~~> true. * We will of course synthesize an assertion in the generated code * (see below). *) let ctx = - apply_symbolic_expansion_non_borrow config meta sv (SeLiteral (VBool true)) - ctx + apply_symbolic_expansion_non_borrow config meta sv + (SeLiteral (VBool true)) ctx in (* Continue *) let expr = cf Unit ctx in (* Add the synthesized assertion *) S.synthesize_assertion ctx v expr | _ -> - craise - meta ("Expected a boolean, got: " ^ typed_value_to_string ~meta:(Some meta) ctx v) + craise meta + ("Expected a boolean, got: " + ^ typed_value_to_string ~meta:(Some meta) ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -210,15 +217,16 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) a variant with all its fields set to {!Bottom}. For instance, something like: [Cons Bottom Bottom]. *) -let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_id : VariantId.id) : - st_cm_fun = +let set_discriminant (config : config) (meta : Meta.meta) (p : place) + (variant_id : VariantId.id) : st_cm_fun = fun cf ctx -> log#ldebug (lazy ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p ^ "\n- variant id: " ^ VariantId.to_string variant_id - ^ "\n- initial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ "\n- initial context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Access the value *) let access = Write in let cc = update_ctx_along_read_place config meta access p in @@ -253,8 +261,8 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_i let bottom_v = match type_id with | TAdtId def_id -> - compute_expanded_bottom_adt_value meta ctx def_id (Some variant_id) - generics + compute_expanded_bottom_adt_value meta ctx def_id + (Some variant_id) generics | _ -> craise meta "Unreachable" in assign_to_place config meta bottom_v p (cf Unit) ctx @@ -269,8 +277,7 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_i * or reset an already initialized value, really. *) craise meta "Unexpected value" | _, (VAdt _ | VBottom) -> craise meta "Inconsistent state" - | _, (VLiteral _ | VBorrow _ | VLoan _) -> - craise meta "Unexpected value" + | _, (VLiteral _ | VBorrow _ | VLoan _) -> craise meta "Unexpected value" in (* Compose and apply *) comp cc update_value cf ctx @@ -285,8 +292,8 @@ let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) (** Small helper: compute the type of the return value for a specific instantiation of an assumed function. *) -let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : assumed_fun_id) - (generics : generic_args) : ety = +let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) + (fid : assumed_fun_id) (generics : generic_args) : ety = sanity_check (generics.trait_refs = []) meta; (* [Box::free] has a special treatment *) match fid with @@ -311,8 +318,8 @@ let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : in AssociatedTypes.ctx_normalize_erase_ty meta ctx ty -let move_return_value (config : config) (meta : Meta.meta) (pop_return_value : bool) - (cf : typed_value option -> m_fun) : m_fun = +let move_return_value (config : config) (meta : Meta.meta) + (pop_return_value : bool) (cf : typed_value option -> m_fun) : m_fun = fun ctx -> if pop_return_value then let ret_vid = VarId.zero in @@ -354,7 +361,9 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) match ret_value with | None -> () | Some ret_value -> - sanity_check (not (bottom_in_value ctx.ended_regions ret_value)) meta) + sanity_check + (not (bottom_in_value ctx.ended_regions ret_value)) + meta) in (* Drop the outer *loans* we find in the local variables *) @@ -377,7 +386,7 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) log#ldebug (lazy ("pop_frame: after dropping outer loans in local variables:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx))) + ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* Pop the frame - we remove the [Frame] delimiter, and reintroduce all @@ -402,7 +411,8 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) comp cc cf_pop cf ctx (** Pop the current frame and assign the returned value to its destination. *) -let pop_frame_assign (config : config) (meta : Meta.meta) (dest : place) : cm_fun = +let pop_frame_assign (config : config) (meta : Meta.meta) (dest : place) : + cm_fun = let cf_pop = pop_frame config meta true in let cf_assign cf ret_value : m_fun = assign_to_place config meta (Option.get ret_value) dest cf @@ -410,7 +420,8 @@ let pop_frame_assign (config : config) (meta : Meta.meta) (dest : place) : cm_fu comp cf_pop cf_assign (** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_new_concrete (config : config) (meta : Meta.meta) (generics : generic_args) : cm_fun = +let eval_box_new_concrete (config : config) (meta : Meta.meta) + (generics : generic_args) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) match @@ -477,9 +488,12 @@ let eval_box_free (config : config) (meta : Meta.meta) (generics : generic_args) match (generics.regions, generics.types, generics.const_generics, args) with | [], [ boxed_ty ], [], [ Move input_box_place ] -> (* Required type checking *) - let input_box = InterpreterPaths.read_place meta Write input_box_place ctx in + let input_box = + InterpreterPaths.read_place meta Write input_box_place ctx + in (let input_ty = ty_get_box input_box.ty in - sanity_check (input_ty = boxed_ty)) meta; + sanity_check (input_ty = boxed_ty)) + meta; (* Drop the value *) let cc = drop_value config meta input_box_place in @@ -492,8 +506,8 @@ let eval_box_free (config : config) (meta : Meta.meta) (generics : generic_args) | _ -> craise meta "Inconsistent state" (** Evaluate a non-local function call in concrete mode *) -let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) (fid : assumed_fun_id) - (call : call) : cm_fun = +let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) + (fid : assumed_fun_id) (call : call) : cm_fun = let args = call.args in let dest = call.dest in match call.func with @@ -504,7 +518,7 @@ let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) (fi let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - sanity_check (generics.const_generics = []) meta; + sanity_check (generics.const_generics = []) meta; (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -535,7 +549,9 @@ let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) (fi (* Create and push the return variable *) let ret_vid = VarId.zero in - let ret_ty = get_assumed_function_return_type meta ctx fid generics in + let ret_ty = + get_assumed_function_return_type meta ctx fid generics + in let ret_var = mk_var ret_vid (Some "@return") ret_ty in let cc = comp cc (push_uninitialized_var meta ret_var) in @@ -728,8 +744,8 @@ let create_push_abstractions_from_abs_region_groups which means that whenever we call a provided trait method, we do not refer to a trait clause but directly to the method provided in the trait declaration. *) -let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call) (ctx : eval_ctx) - : +let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) + (call : call) (ctx : eval_ctx) : fun_id_or_trait_method_ref * generic_args * (generic_args * trait_instance_id) option @@ -823,7 +839,9 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call | None -> (* If not found, lookup the methods provided by the trait *declaration* (remember: for now, we forbid overriding provided methods) *) - cassert (trait_impl.provided_methods = []) meta "Overriding provided methods is currently forbidden"; + cassert + (trait_impl.provided_methods = []) + meta "Overriding provided methods is currently forbidden"; let trait_decl = ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id @@ -912,8 +930,8 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call in let tr_self = TraitRef trait_ref in let inst_sg = - instantiate_fun_sig meta ctx generics tr_self method_def.signature - regions_hierarchy + instantiate_fun_sig meta ctx generics tr_self + method_def.signature regions_hierarchy in ( func.func, func.generics, @@ -930,7 +948,9 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = (lazy ("\n**About to evaluate statement**: [\n" ^ statement_to_string_with_tab ctx st - ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string ~meta:(Some st.meta) ctx ^ "\n\n")); + ^ "\n]\n\n**Context**:\n" + ^ eval_ctx_to_string ~meta:(Some st.meta) ctx + ^ "\n\n")); (* Take a snapshot of the current context for the purpose of generating pretty names *) let cc = S.cf_save_snapshot in @@ -963,11 +983,14 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = log#ldebug (lazy ("about to assign to place: " ^ place_to_string ctx p - ^ "\n- Context:\n" ^ eval_ctx_to_string ~meta:(Some st.meta) ctx)); + ^ "\n- Context:\n" + ^ eval_ctx_to_string ~meta:(Some st.meta) ctx)); match res with | Error EPanic -> cf Panic ctx | Ok rv -> ( - let expr = assign_to_place config st.meta rv p (cf Unit) ctx in + let expr = + assign_to_place config st.meta rv p (cf Unit) ctx + in (* Update the synthesized AST - here we store meta-information. * We do it only in specific cases (it is not always useful, and * also it can lead to issues - for instance, if we borrow a @@ -983,8 +1006,9 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = | Some rp -> Some (S.mk_mplace st.meta rp ctx) | None -> None in - S.synthesize_assignment ctx (S.mk_mplace st.meta p ctx) rv rp expr - ) + S.synthesize_assignment ctx + (S.mk_mplace st.meta p ctx) + rv rp expr) in (* Compose and apply *) @@ -1033,11 +1057,14 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) (* Treat the evaluation of the global as a call to the global body *) let func = { func = FunId (FRegular global.body); generics } in let call = { func = FnOpRegular func; args = []; dest } in - (eval_transparent_function_call_concrete config global.meta global.body call) cf ctx + (eval_transparent_function_call_concrete config global.meta global.body + call) + cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) - cassert (ty_no_regions global.ty) global.meta "Const globals should not contain regions"; + cassert (ty_no_regions global.ty) global.meta + "Const globals should not contain regions"; (* Instantiate the type *) (* There shouldn't be any reference to Self *) let tr_self : trait_instance_id = UnknownTrait __FUNCTION__ in @@ -1051,13 +1078,16 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) in let sval = mk_fresh_symbolic_value global.meta ty in let cc = - assign_to_place config global.meta (mk_typed_value_from_symbolic_value sval) dest + assign_to_place config global.meta + (mk_typed_value_from_symbolic_value sval) + dest in let e = cc (cf Unit) ctx in S.synthesize_global_eval gid generics sval e (** Evaluate a switch *) -and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_fun = +and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : + st_cm_fun = fun cf ctx -> (* We evaluate the operand in two steps: * first we prepare it, then we check if its value is concrete or @@ -1151,7 +1181,8 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_f let access = Read in let expand_prim_copy = false in let cf_read_p cf : m_fun = - access_rplace_reorganize_and_read config meta expand_prim_copy access p cf + access_rplace_reorganize_and_read config meta expand_prim_copy access + p cf in (* Match on the value *) let cf_match (cf : st_m_fun) (p_v : typed_value) : m_fun = @@ -1174,7 +1205,8 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_f | VSymbolic sv -> (* Expand the symbolic value - may lead to branching *) let cf_expand = - expand_symbolic_adt config meta sv (Some (S.mk_mplace meta p ctx)) + expand_symbolic_adt config meta sv + (Some (S.mk_mplace meta p ctx)) in (* Re-evaluate the switch - the value is not symbolic anymore, which means we will go to the other branch *) @@ -1188,7 +1220,8 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_f cf_match cf ctx (** Evaluate a function call (auxiliary helper for [eval_statement]) *) -and eval_function_call (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = +and eval_function_call (config : config) (meta : Meta.meta) (call : call) : + st_cm_fun = (* There are several cases: - this is a local function, in which case we execute its body - this is an assumed function, in which case there is a special treatment @@ -1198,7 +1231,8 @@ and eval_function_call (config : config) (meta : Meta.meta) (call : call) : st_c | ConcreteMode -> eval_function_call_concrete config meta call | SymbolicMode -> eval_function_call_symbolic config meta call -and eval_function_call_concrete (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = +and eval_function_call_concrete (config : config) (meta : Meta.meta) + (call : call) : st_cm_fun = fun cf ctx -> match call.func with | FnOpMove _ -> craise meta "Closures are not supported yet" @@ -1214,7 +1248,8 @@ and eval_function_call_concrete (config : config) (meta : Meta.meta) (call : cal eval_assumed_function_call_concrete config meta fid call (cf Unit) ctx | TraitMethod _ -> craise meta "Unimplemented") -and eval_function_call_symbolic (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = +and eval_function_call_symbolic (config : config) (meta : Meta.meta) + (call : call) : st_cm_fun = match call.func with | FnOpMove _ -> craise meta "Closures are not supported yet" | FnOpRegular func -> ( @@ -1235,7 +1270,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - sanity_check (generics.const_generics = []) meta; + sanity_check (generics.const_generics = []) meta; fun cf ctx -> (* Retrieve the (correctly instantiated) body *) let def = ctx_lookup_fun_decl ctx fid in @@ -1243,14 +1278,14 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let body = match def.body with | None -> - craise - meta - ("Can't evaluate a call to an opaque function: " - ^ name_to_string ctx def.name) + craise meta + ("Can't evaluate a call to an opaque function: " + ^ name_to_string ctx def.name) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) - cassert (generics.trait_refs = []) body.meta "Traits are not supported yet in concrete mode"; + cassert (generics.trait_refs = []) body.meta + "Traits are not supported yet in concrete mode"; (* There shouldn't be any reference to Self *) let tr_self = UnknownTrait __FUNCTION__ in let subst = @@ -1259,7 +1294,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - sanity_check(List.length args = body.arg_count) body.meta; + sanity_check (List.length args = body.arg_count) body.meta; let cc = eval_operands config body.meta args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result @@ -1279,7 +1314,8 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) in let cc = - comp_transmit cc (push_var meta ret_var (mk_bottom meta ret_var.var_ty)) + comp_transmit cc + (push_var meta ret_var (mk_bottom meta ret_var.var_ty)) in (* 2. Push the input values *) @@ -1315,14 +1351,16 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) (call : call) : - st_cm_fun = +and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) + (call : call) : st_cm_fun = fun cf ctx -> let func, generics, trait_method_generics, def, regions_hierarchy, inst_sg = eval_transparent_function_call_symbolic_inst meta call ctx in (* Sanity check *) - sanity_check (List.length call.args = List.length def.signature.inputs) def.meta; + sanity_check + (List.length call.args = List.length def.signature.inputs) + def.meta; (* Evaluate the function call *) eval_function_call_symbolic_from_inst_sig config def.meta func def.signature regions_hierarchy inst_sg generics trait_method_generics call.args call.dest @@ -1339,8 +1377,8 @@ and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) overriding them. We treat them as regular method, which take an additional trait ref as input. *) -and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.meta) - (fid : fun_id_or_trait_method_ref) (sg : fun_sig) +and eval_function_call_symbolic_from_inst_sig (config : config) + (meta : Meta.meta) (fid : fun_id_or_trait_method_ref) (sg : fun_sig) (regions_hierarchy : region_var_groups) (inst_sg : inst_fun_sig) (generics : generic_args) (trait_method_generics : (generic_args * trait_instance_id) option) @@ -1365,7 +1403,9 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.met let ret_av regions = mk_aproj_loans_value_from_symbolic_value regions ret_spc in - let args_places = List.map (fun p -> S.mk_opt_place_from_op meta p ctx) args in + let args_places = + List.map (fun p -> S.mk_opt_place_from_op meta p ctx) args + in let dest_place = Some (S.mk_mplace meta dest ctx) in (* Evaluate the input operands *) @@ -1378,20 +1418,22 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.met let args_with_rtypes = List.combine args inst_sg.inputs in (* Check the type of the input arguments *) - cassert ( - List.for_all - (fun ((arg, rty) : typed_value * rty) -> - arg.ty = Subst.erase_regions rty) - args_with_rtypes) meta "TODO: Error message"; + cassert + (List.for_all + (fun ((arg, rty) : typed_value * rty) -> + arg.ty = Subst.erase_regions rty) + args_with_rtypes) + meta "TODO: Error message"; (* Check that the input arguments don't contain symbolic values that can't * be fed to functions (i.e., symbolic values output from function return * values and which contain borrows of borrows can't be used as function * inputs *) - sanity_check ( - List.for_all - (fun arg -> - not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) - args) meta; + sanity_check + (List.for_all + (fun arg -> + not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) + args) + meta; (* Initialize the abstractions and push them in the context. * First, we define the function which, given an initialized, empty @@ -1486,18 +1528,19 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.met cc (cf Unit) ctx (** Evaluate a non-local function call in symbolic mode *) -and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) (fid : assumed_fun_id) - (call : call) (func : fn_ptr) : st_cm_fun = +and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) + (fid : assumed_fun_id) (call : call) (func : fn_ptr) : st_cm_fun = fun cf ctx -> let generics = func.generics in let args = call.args in let dest = call.dest in (* Sanity check: make sure the type parameters don't contain regions - * this is a current limitation of our synthesis *) - sanity_check ( - List.for_all - (fun ty -> not (ty_has_borrows ctx.type_ctx.type_infos ty)) - generics.types) meta; + sanity_check + (List.for_all + (fun ty -> not (ty_has_borrows ctx.type_ctx.type_infos ty)) + generics.types) + meta; (* There are two cases (and this is extremely annoying): - the function is not box_free @@ -1534,8 +1577,9 @@ and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) (fi in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config meta (FunId (FAssumed fid)) sg - regions_hierarchy inst_sig generics None args dest cf ctx + eval_function_call_symbolic_from_inst_sig config meta + (FunId (FAssumed fid)) sg regions_hierarchy inst_sig generics None args + dest cf ctx (** Evaluate a statement seen as a function body *) and eval_function_body (config : config) (body : statement) : st_cm_fun = @@ -1550,7 +1594,8 @@ and eval_function_body (config : config) (body : statement) : st_cm_fun = * checking the invariants *) let cc = greedy_expand_symbolic_values config body.meta in (* Sanity check *) - let cc = comp_check_ctx cc (Invariants.check_invariants body.meta) in (* Check if right meta *) + let cc = comp_check_ctx cc (Invariants.check_invariants body.meta) in + (* Check if right meta *) (* Continue *) cc (cf res) in diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index 13743cb1..7a2783bb 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -16,7 +16,8 @@ open Cps If the boolean is false, we don't move the return value, and call the continuation with [None]. *) -val pop_frame : config -> Meta.meta -> bool -> (typed_value option -> m_fun) -> m_fun +val pop_frame : + config -> Meta.meta -> bool -> (typed_value option -> m_fun) -> m_fun (** Helper. diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index a24cd543..9ffab771 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -17,7 +17,8 @@ let log = Logging.interpreter_log (** Auxiliary function - call a function which requires a continuation, and return the let context given to the continuation *) -let get_cf_ctx_no_synth (meta : Meta.meta) (f : cm_fun) (ctx : eval_ctx) : eval_ctx = +let get_cf_ctx_no_synth (meta : Meta.meta) (f : cm_fun) (ctx : eval_ctx) : + eval_ctx = let nctx = ref None in let cf ctx = sanity_check (!nctx = None) meta; @@ -62,9 +63,14 @@ let statement_to_string ctx = Print.EvalCtx.statement_to_string ctx "" " " let statement_to_string_with_tab ctx = Print.EvalCtx.statement_to_string ctx " " " " -let env_elem_to_string meta ctx = Print.EvalCtx.env_elem_to_string ~meta:(Some meta) ctx "" " " -let env_to_string meta ctx env = eval_ctx_to_string ~meta:(Some meta) { ctx with env } -let abs_to_string meta ctx = Print.EvalCtx.abs_to_string ~meta:(Some meta) ctx "" " " +let env_elem_to_string meta ctx = + Print.EvalCtx.env_elem_to_string ~meta:(Some meta) ctx "" " " + +let env_to_string meta ctx env = + eval_ctx_to_string ~meta:(Some meta) { ctx with env } + +let abs_to_string meta ctx = + Print.EvalCtx.abs_to_string ~meta:(Some meta) ctx "" " " let same_symbolic_id (sv0 : symbolic_value) (sv1 : symbolic_value) : bool = sv0.sv_id = sv1.sv_id @@ -77,19 +83,20 @@ let mk_place_from_var_id (var_id : VarId.id) : place = { var_id; projection = [] } (** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (meta : Meta.meta) (ty : ty) : symbolic_value = +let mk_fresh_symbolic_value (meta : Meta.meta) (ty : ty) : symbolic_value = (* Sanity check *) sanity_check (ty_is_rty ty) meta; let sv_id = fresh_symbolic_value_id () in let svalue = { sv_id; sv_ty = ty } in svalue -let mk_fresh_symbolic_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : symbolic_value = +let mk_fresh_symbolic_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : + symbolic_value = sanity_check (ty_no_regions ty) meta; mk_fresh_symbolic_value meta ty (** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = +let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = sanity_check (ty_is_rty rty) meta; let ty = Substitute.erase_regions rty in (* Generate the fresh a symbolic value *) @@ -97,7 +104,8 @@ let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = let value = VSymbolic value in { value; ty } -let mk_fresh_symbolic_typed_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : typed_value = +let mk_fresh_symbolic_typed_value_from_no_regions_ty (meta : Meta.meta) + (ty : ty) : typed_value = sanity_check (ty_no_regions ty) meta; mk_fresh_symbolic_typed_value meta ty @@ -125,8 +133,9 @@ let mk_aproj_loans_value_from_symbolic_value (regions : RegionId.Set.t) else { value = AIgnored; ty = svalue.sv_ty } (** Create a borrows projector from a symbolic value *) -let mk_aproj_borrows_from_symbolic_value (meta : Meta.meta) (proj_regions : RegionId.Set.t) - (svalue : symbolic_value) (proj_ty : ty) : aproj = +let mk_aproj_borrows_from_symbolic_value (meta : Meta.meta) + (proj_regions : RegionId.Set.t) (svalue : symbolic_value) (proj_ty : ty) : + aproj = sanity_check (ty_is_rty proj_ty) meta; if ty_has_regions_in_set proj_regions proj_ty then AProjBorrows (svalue, proj_ty) @@ -141,8 +150,8 @@ let borrow_in_asb (bid : BorrowId.id) (asb : abstract_shared_borrows) : bool = List.exists (borrow_is_asb bid) asb (** TODO: move *) -let remove_borrow_from_asb (meta : Meta.meta) (bid : BorrowId.id) (asb : abstract_shared_borrows) : - abstract_shared_borrows = +let remove_borrow_from_asb (meta : Meta.meta) (bid : BorrowId.id) + (asb : abstract_shared_borrows) : abstract_shared_borrows = let removed = ref 0 in let asb = List.filter @@ -460,8 +469,8 @@ let initialize_eval_ctx (meta : Meta.meta) (ctx : decls_ctx) region ids. This is mostly used in preparation of function calls (when evaluating in symbolic mode). *) -let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (generics : generic_args) - (tr_self : trait_instance_id) (sg : fun_sig) +let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) + (generics : generic_args) (tr_self : trait_instance_id) (sg : fun_sig) (regions_hierarchy : region_var_groups) : inst_fun_sig = log#ldebug (lazy @@ -514,8 +523,8 @@ let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (generics : generic_ in (* Substitute the signature *) let inst_sig = - AssociatedTypes.ctx_subst_norm_signature meta ctx asubst rsubst tsubst cgsubst - tr_subst tr_self sg regions_hierarchy + AssociatedTypes.ctx_subst_norm_signature meta ctx asubst rsubst tsubst + cgsubst tr_subst tr_self sg regions_hierarchy in (* Return *) inst_sig diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 9b389ba5..1c10bf7e 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -48,14 +48,16 @@ type borrow_kind = BMut | BShared | BReserved - loans and borrows are correctly related - a two-phase borrow can't point to a value inside an abstraction *) -let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = +let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : + unit = (* Link all the borrow ids to a representant - necessary because of shared * borrows/loans *) let ids_reprs : BorrowId.id BorrowId.Map.t ref = ref BorrowId.Map.empty in (* Link all the id representants to a borrow information *) let borrows_infos : borrow_info BorrowId.Map.t ref = ref BorrowId.Map.empty in let context_to_string () : string = - eval_ctx_to_string ~meta:(Some meta) ctx ^ "- representants:\n" + eval_ctx_to_string ~meta:(Some meta) ctx + ^ "- representants:\n" ^ ids_reprs_to_string " " !ids_reprs ^ "\n- info:\n" ^ borrows_infos_to_string " " !borrows_infos @@ -194,9 +196,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let infos = BorrowId.Map.update repr_bid (fun x -> - match x with - | Some _ -> Some info - | None -> craise meta "Unreachable") + match x with Some _ -> Some info | None -> craise meta "Unreachable") !borrows_infos in borrows_infos := infos @@ -278,9 +278,10 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : (fun _ info -> (* Note that we can't directly compare the sets - I guess they are * different depending on the order in which we add the elements... *) - sanity_check ( - BorrowId.Set.elements info.loan_ids - = BorrowId.Set.elements info.borrow_ids) meta; + sanity_check + (BorrowId.Set.elements info.loan_ids + = BorrowId.Set.elements info.borrow_ids) + meta; match info.loan_kind with | RMut -> sanity_check (BorrowId.Set.cardinal info.loan_ids = 1) meta | RShared -> ()) @@ -297,7 +298,9 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = method! visit_VBottom info = (* No ⊥ inside borrowed values *) - sanity_check (Config.allow_bottom_below_borrow || not info.outer_borrow) meta + sanity_check + (Config.allow_bottom_below_borrow || not info.outer_borrow) + meta method! visit_ABottom _info = (* ⊥ inside an abstraction is not the same as in a regular value *) @@ -367,7 +370,8 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let info = { outer_borrow = false; outer_shared = false } in visitor#visit_eval_ctx info ctx -let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : unit = +let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : + unit = match (cv, ty) with | VScalar sv, TInteger int_ty -> sanity_check (sv.int_ty = int_ty) meta | VBool _, TBool | VChar _, TChar -> () @@ -413,13 +417,18 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - sanity_check ( - List.length generics.regions = List.length def.generics.regions) meta; - sanity_check (List.length generics.types = List.length def.generics.types) meta; + sanity_check + (List.length generics.regions = List.length def.generics.regions) + meta; + sanity_check + (List.length generics.types = List.length def.generics.types) + meta; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - sanity_check (VariantId.to_int variant_id < List.length variants) meta + sanity_check + (VariantId.to_int variant_id < List.length variants) + meta | None, Struct _ -> () | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) @@ -429,7 +438,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : typed_value * ty) -> sanity_check (v.ty = ty) meta) + (fun ((v, ty) : typed_value * ty) -> + sanity_check (v.ty = ty) meta) fields_with_types (* Tuple case *) | VAdt av, TAdt (TTuple, generics) -> @@ -442,7 +452,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : typed_value * ty) -> sanity_check (v.ty = ty) meta) + (fun ((v, ty) : typed_value * ty) -> + sanity_check (v.ty = ty) meta) fields_with_types (* Assumed type case *) | VAdt av, TAdt (TAssumed aty_id, generics) -> ( @@ -459,10 +470,11 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = sanity_check (inner_value.ty = inner_ty) meta | TArray, inner_values, _, [ inner_ty ], [ cg ] -> (* *) - sanity_check ( - List.for_all - (fun (v : typed_value) -> v.ty = inner_ty) - inner_values) meta; + sanity_check + (List.for_all + (fun (v : typed_value) -> v.ty = inner_ty) + inner_values) + meta; (* The length is necessarily concrete *) let len = (ValuesUtils.literal_as_scalar @@ -484,9 +496,10 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = sanity_check (sv.ty = ref_ty) meta | _ -> craise meta "Inconsistent context") | VMutBorrow (_, bv), RMut -> - sanity_check ( - (* Check that the borrowed value has the proper type *) - bv.ty = ref_ty) meta + sanity_check + ((* Check that the borrowed value has the proper type *) + bv.ty = ref_ty) + meta | _ -> craise meta "Erroneous typing") | VLoan lc, ty -> ( match lc with @@ -495,7 +508,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in match glc with - | Concrete (VMutBorrow (_, bv)) -> sanity_check (bv.ty = ty) meta + | Concrete (VMutBorrow (_, bv)) -> + sanity_check (bv.ty = ty) meta | Abstract (AMutBorrow (_, sv)) -> sanity_check (Substitute.erase_regions sv.ty = ty) meta | _ -> craise meta "Inconsistent context")) @@ -525,16 +539,22 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - sanity_check ( - List.length generics.regions = List.length def.generics.regions) meta; - sanity_check (List.length generics.types = List.length def.generics.types) meta; - sanity_check ( - List.length generics.const_generics - = List.length def.generics.const_generics) meta; + sanity_check + (List.length generics.regions = List.length def.generics.regions) + meta; + sanity_check + (List.length generics.types = List.length def.generics.types) + meta; + sanity_check + (List.length generics.const_generics + = List.length def.generics.const_generics) + meta; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - sanity_check (VariantId.to_int variant_id < List.length variants) meta + sanity_check + (VariantId.to_int variant_id < List.length variants) + meta | None, Struct _ -> () | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) @@ -544,7 +564,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : typed_avalue * ty) -> sanity_check (v.ty = ty) meta) + (fun ((v, ty) : typed_avalue * ty) -> + sanity_check (v.ty = ty) meta) fields_with_types (* Tuple case *) | AAdt av, TAdt (TTuple, generics) -> @@ -557,7 +578,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : typed_avalue * ty) -> sanity_check (v.ty = ty) meta) + (fun ((v, ty) : typed_avalue * ty) -> + sanity_check (v.ty = ty) meta) fields_with_types (* Assumed type case *) | AAdt av, TAdt (TAssumed aty_id, generics) -> ( @@ -587,7 +609,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | Abstract (ASharedLoan (_, sv, _)) -> sanity_check (sv.ty = Substitute.erase_regions ref_ty) meta | _ -> craise meta "Inconsistent context") - | AIgnoredMutBorrow (_opt_bid, av), RMut -> sanity_check (av.ty = ref_ty) meta + | AIgnoredMutBorrow (_opt_bid, av), RMut -> + sanity_check (av.ty = ref_ty) meta | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, RMut ) -> sanity_check (given_back.ty = ref_ty) meta; @@ -604,18 +627,23 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let glc = lookup_borrow meta ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> - sanity_check (bv.ty = Substitute.erase_regions borrowed_aty) meta + sanity_check + (bv.ty = Substitute.erase_regions borrowed_aty) + meta | Abstract (AMutBorrow (_, sv)) -> - sanity_check ( - Substitute.erase_regions sv.ty - = Substitute.erase_regions borrowed_aty) meta + sanity_check + (Substitute.erase_regions sv.ty + = Substitute.erase_regions borrowed_aty) + meta | _ -> craise meta "Inconsistent context") | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in sanity_check (child_av.ty = borrowed_aty) meta | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - sanity_check (sv.ty = Substitute.erase_regions borrowed_aty) meta; + sanity_check + (sv.ty = Substitute.erase_regions borrowed_aty) + meta; (* TODO: the type of aloans doesn't make sense, see above *) sanity_check (child_av.ty = borrowed_aty) meta | AEndedMutLoan { given_back; child; given_back_meta = _ } @@ -624,7 +652,9 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = sanity_check (given_back.ty = borrowed_aty) meta; sanity_check (child.ty = borrowed_aty) meta | AIgnoredSharedLoan child_av -> - sanity_check (child_av.ty = aloan_get_expected_child_type aty) meta) + sanity_check + (child_av.ty = aloan_get_expected_child_type aty) + meta) | ASymbolic aproj, ty -> ( let ty1 = Substitute.erase_regions ty in match aproj with @@ -772,7 +802,9 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = if ty_has_borrows ctx.type_ctx.type_infos info.ty then sanity_check (info.env_count <= 1) meta; (* A duplicated symbolic value is necessarily primitively copyable *) - sanity_check (info.env_count <= 1 || ty_is_primitively_copyable info.ty) meta; + sanity_check + (info.env_count <= 1 || ty_is_primitively_copyable info.ty) + meta; sanity_check (info.aproj_borrows = [] || info.aproj_loans <> []) meta; (* At the same time: @@ -796,8 +828,10 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Check that the union of the loan projectors contains the borrow projections. *) List.iter (fun binfo -> - sanity_check ( - projection_contains meta info.ty loan_regions binfo.proj_ty binfo.regions) meta) + sanity_check + (projection_contains meta info.ty loan_regions binfo.proj_ty + binfo.regions) + meta) info.aproj_borrows; () in @@ -806,7 +840,9 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = let check_invariants (meta : Meta.meta) (ctx : eval_ctx) : unit = if !Config.sanity_checks then ( - log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + log#ldebug + (lazy + ("Checking invariants:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); check_loans_borrows_relation_invariant meta ctx; check_borrowed_values_invariant meta ctx; check_typing_invariant meta ctx; diff --git a/compiler/Main.ml b/compiler/Main.ml index f8765247..41addc81 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -113,7 +113,9 @@ let () = Arg.Clear lean_gen_lakefile, " Generate a default lakefile.lean (Lean only)" ); ("-print-llbc", Arg.Set print_llbc, " Print the imported LLBC"); - ("-abort-on-error", Arg.Set fail_hard, "Abort on the first encountered error"); + ( "-abort-on-error", + Arg.Set fail_hard, + "Abort on the first encountered error" ); ( "-tuple-nested-proj", Arg.Set use_nested_tuple_projectors, " Use nested projectors for tuples (e.g., (0, 1).snd.fst instead of \ diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index c10dbf5d..42857a88 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -215,7 +215,8 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = inherit [_] map_statement as super method! visit_Loop entered_loop loop = - cassert (not entered_loop) st.meta "Nested loops are not supported yet"; + cassert (not entered_loop) st.meta + "Nested loops are not supported yet"; super#visit_Loop true loop method! visit_Break _ i = @@ -396,9 +397,16 @@ let remove_shallow_borrows (crate : crate) (f : fun_decl) : fun_decl = let check_visitor = object inherit [_] iter_statement as super - (* Remember the span of the statement we enter *) + (* Remember the span of the statement we enter *) + method! visit_statement _ st = super#visit_statement st.meta st - method! visit_var_id meta id = cassert (not (VarId.Set.mem id !filtered)) meta "Filtered variables should have completely disappeared from the body" + + method! visit_var_id meta id = + cassert + (not (VarId.Set.mem id !filtered)) + meta + "Filtered variables should have completely disappeared from the \ + body" end in check_visitor#visit_statement body.meta body; diff --git a/compiler/Print.ml b/compiler/Print.ml index 47ae9b79..b570bf5f 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -43,12 +43,13 @@ module Values = struct * typed_avalue_to_string. At some point we had done it, because [typed_value] * and [typed_avalue] were instances of the same general type [g_typed_value], * but then we removed this general type because it proved to be a bad idea. *) - let rec typed_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_value) : string = + let rec typed_value_to_string ?(meta : Meta.meta option = None) + (env : fmt_env) (v : typed_value) : string = match v.value with | VLiteral cv -> literal_to_string cv | VAdt av -> ( let field_values = - List.map (typed_value_to_string~meta:meta env) av.field_values + List.map (typed_value_to_string ~meta env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -83,28 +84,31 @@ module Values = struct | TArray, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" - | _ -> craise_opt_meta meta ("Inconsistent value: " ^ show_typed_value v) - ) + | _ -> + craise_opt_meta meta + ("Inconsistent value: " ^ show_typed_value v)) | _ -> craise_opt_meta meta "Inconsistent typed value") | VBottom -> "⊥ : " ^ ty_to_string env v.ty - | VBorrow bc -> borrow_content_to_string ~meta:meta env bc - | VLoan lc -> loan_content_to_string ~meta:meta env lc + | VBorrow bc -> borrow_content_to_string ~meta env bc + | VLoan lc -> loan_content_to_string ~meta env lc | VSymbolic s -> symbolic_value_to_string env s - and borrow_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (bc : borrow_content) : string = + and borrow_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (bc : borrow_content) : string = match bc with | VSharedBorrow bid -> "shared_borrow@" ^ BorrowId.to_string bid | VMutBorrow (bid, tv) -> "mut_borrow@" ^ BorrowId.to_string bid ^ " (" - ^ typed_value_to_string ~meta:meta env tv + ^ typed_value_to_string ~meta env tv ^ ")" | VReservedMutBorrow bid -> "reserved_borrow@" ^ BorrowId.to_string bid - and loan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (lc : loan_content) : string = + and loan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (lc : loan_content) : string = match lc with | VSharedLoan (loans, v) -> let loans = BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string ~meta:meta env v ^ ")" + "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string ~meta env v ^ ")" | VMutLoan bid -> "ml@" ^ BorrowId.to_string bid let abstract_shared_borrow_to_string (env : fmt_env) @@ -142,11 +146,12 @@ module Values = struct | AEndedProjBorrows _mv -> "_" | AIgnoredProjBorrows -> "_" - let rec typed_avalue_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_avalue) : string = + let rec typed_avalue_to_string ?(meta : Meta.meta option = None) + (env : fmt_env) (v : typed_avalue) : string = match v.value with | AAdt av -> ( let field_values = - List.map (typed_avalue_to_string ~meta:meta env) av.field_values + List.map (typed_avalue_to_string ~meta env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -181,72 +186,73 @@ module Values = struct | _ -> craise_opt_meta meta "Inconsistent value") | _ -> craise_opt_meta meta "Inconsistent typed value") | ABottom -> "⊥ : " ^ ty_to_string env v.ty - | ABorrow bc -> aborrow_content_to_string ~meta:meta env bc - | ALoan lc -> aloan_content_to_string ~meta:meta env lc + | ABorrow bc -> aborrow_content_to_string ~meta env bc + | ALoan lc -> aloan_content_to_string ~meta env lc | ASymbolic s -> aproj_to_string env s | AIgnored -> "_" - and aloan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (lc : aloan_content) : string = + and aloan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (lc : aloan_content) : string = match lc with | AMutLoan (bid, av) -> "@mut_loan(" ^ BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | ASharedLoan (loans, v, av) -> let loans = BorrowId.Set.to_string None loans in "@shared_loan(" ^ loans ^ ", " - ^ typed_value_to_string ~meta:meta env v + ^ typed_value_to_string ~meta env v ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | AEndedMutLoan ml -> "@ended_mut_loan{" - ^ typed_avalue_to_string ~meta:meta env ml.child + ^ typed_avalue_to_string ~meta env ml.child ^ "; " - ^ typed_avalue_to_string ~meta:meta env ml.given_back + ^ typed_avalue_to_string ~meta env ml.given_back ^ " }" | AEndedSharedLoan (v, av) -> "@ended_shared_loan(" - ^ typed_value_to_string ~meta:meta env v + ^ typed_value_to_string ~meta env v ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | AIgnoredMutLoan (opt_bid, av) -> "@ignored_mut_loan(" ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | AEndedIgnoredMutLoan ml -> "@ended_ignored_mut_loan{ " - ^ typed_avalue_to_string ~meta:meta env ml.child + ^ typed_avalue_to_string ~meta env ml.child ^ "; " - ^ typed_avalue_to_string ~meta:meta env ml.given_back + ^ typed_avalue_to_string ~meta env ml.given_back ^ "}" | AIgnoredSharedLoan sl -> - "@ignored_shared_loan(" ^ typed_avalue_to_string ~meta:meta env sl ^ ")" + "@ignored_shared_loan(" ^ typed_avalue_to_string ~meta env sl ^ ")" - and aborrow_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (bc : aborrow_content) : string - = + and aborrow_content_to_string ?(meta : Meta.meta option = None) + (env : fmt_env) (bc : aborrow_content) : string = match bc with | AMutBorrow (bid, av) -> "mb@" ^ BorrowId.to_string bid ^ " (" - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | ASharedBorrow bid -> "sb@" ^ BorrowId.to_string bid | AIgnoredMutBorrow (opt_bid, av) -> "@ignored_mut_borrow(" ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | AEndedMutBorrow (_mv, child) -> - "@ended_mut_borrow(" ^ typed_avalue_to_string ~meta:meta env child ^ ")" + "@ended_mut_borrow(" ^ typed_avalue_to_string ~meta env child ^ ")" | AEndedIgnoredMutBorrow { child; given_back; given_back_meta = _ } -> "@ended_ignored_mut_borrow{ " - ^ typed_avalue_to_string ~meta:meta env child + ^ typed_avalue_to_string ~meta env child ^ "; " - ^ typed_avalue_to_string ~meta:meta env given_back + ^ typed_avalue_to_string ~meta env given_back ^ ")" | AEndedSharedBorrow -> "@ended_shared_borrow" | AProjSharedBorrow sb -> @@ -276,11 +282,14 @@ module Values = struct ^ ")" | Identity -> "Identity" - let abs_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) (indent : string) - (indent_incr : string) (abs : abs) : string = + let abs_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (verbose : bool) (indent : string) (indent_incr : string) (abs : abs) : + string = let indent2 = indent ^ indent_incr in let avs = - List.map (fun av -> indent2 ^ typed_avalue_to_string ~meta:meta env av) abs.avalues + List.map + (fun av -> indent2 ^ typed_avalue_to_string ~meta env av) + abs.avalues in let avs = String.concat ",\n" avs in let kind = @@ -323,26 +332,27 @@ module Contexts = struct | BVar b -> var_binder_to_string env b | BDummy bid -> dummy_var_id_to_string bid - let env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) - (with_var_types : bool) (indent : string) (indent_incr : string) - (ev : env_elem) : string = + let env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (verbose : bool) (with_var_types : bool) (indent : string) + (indent_incr : string) (ev : env_elem) : string = match ev with | EBinding (var, tv) -> let bv = binder_to_string env var in let ty = if with_var_types then " : " ^ ty_to_string env tv.ty else "" in - indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string ~meta:meta env tv ^ " ;" - | EAbs abs -> abs_to_string ~meta:meta env verbose indent indent_incr abs + indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string ~meta env tv ^ " ;" + | EAbs abs -> abs_to_string ~meta env verbose indent indent_incr abs | EFrame -> craise_opt_meta meta "Can't print a Frame element" - let opt_env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) - (with_var_types : bool) (indent : string) (indent_incr : string) - (ev : env_elem option) : string = + let opt_env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (verbose : bool) (with_var_types : bool) (indent : string) + (indent_incr : string) (ev : env_elem option) : string = match ev with | None -> indent ^ "..." | Some ev -> - env_elem_to_string ~meta:meta env verbose with_var_types indent indent_incr ev + env_elem_to_string ~meta env verbose with_var_types indent indent_incr + ev (** Filters "dummy" bindings from an environment, to gain space and clarity/ See [env_to_string]. *) @@ -379,8 +389,9 @@ module Contexts = struct "..." to gain space and clarity. [with_var_types]: if true, print the type of the variables *) - let env_to_string ?(meta : Meta.meta option = None) (filter : bool) (fmt_env : fmt_env) (verbose : bool) - (with_var_types : bool) (env : env) : string = + let env_to_string ?(meta : Meta.meta option = None) (filter : bool) + (fmt_env : fmt_env) (verbose : bool) (with_var_types : bool) (env : env) : + string = let env = if filter then filter_env env else List.map (fun ev -> Some ev) env in @@ -388,7 +399,8 @@ module Contexts = struct ^ String.concat "\n" (List.map (fun ev -> - opt_env_elem_to_string ~meta:meta fmt_env verbose with_var_types " " " " ev) + opt_env_elem_to_string ~meta fmt_env verbose with_var_types " " + " " ev) env) ^ "\n}" @@ -468,8 +480,8 @@ module Contexts = struct let frames = split_aux [] [] env in frames - let eval_ctx_to_string_gen ?(meta : Meta.meta option = None) (verbose : bool) (filter : bool) - (with_var_types : bool) (ctx : eval_ctx) : string = + let eval_ctx_to_string_gen ?(meta : Meta.meta option = None) (verbose : bool) + (filter : bool) (with_var_types : bool) (ctx : eval_ctx) : string = let fmt_env = eval_ctx_to_fmt_env ctx in let ended_regions = RegionId.Set.to_string None ctx.ended_regions in let frames = split_env_according_to_frames ctx.env in @@ -492,18 +504,20 @@ module Contexts = struct ^ string_of_int !num_bindings ^ "\n- dummy bindings: " ^ string_of_int !num_dummies ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" - ^ env_to_string ~meta:meta filter fmt_env verbose with_var_types f + ^ env_to_string ~meta filter fmt_env verbose with_var_types f ^ "\n") frames in "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames ^ " frame(s)\n" ^ String.concat "" frames - let eval_ctx_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) : string = - eval_ctx_to_string_gen ~meta:meta false true true ctx + let eval_ctx_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) : + string = + eval_ctx_to_string_gen ~meta false true true ctx - let eval_ctx_to_string_no_filter ?(meta : Meta.meta option = None) (ctx : eval_ctx) : string = - eval_ctx_to_string_gen ~meta:meta false false true ctx + let eval_ctx_to_string_no_filter ?(meta : Meta.meta option = None) + (ctx : eval_ctx) : string = + eval_ctx_to_string_gen ~meta false false true ctx end (** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) @@ -541,22 +555,25 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in trait_instance_id_to_string env x - let borrow_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (bc : borrow_content) : string = + let borrow_content_to_string ?(meta : Meta.meta option = None) + (ctx : eval_ctx) (bc : borrow_content) : string = let env = eval_ctx_to_fmt_env ctx in - borrow_content_to_string ~meta:meta env bc + borrow_content_to_string ~meta env bc - let loan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (lc : loan_content) : string = + let loan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (lc : loan_content) : string = let env = eval_ctx_to_fmt_env ctx in - loan_content_to_string ~meta:meta env lc + loan_content_to_string ~meta env lc - let aborrow_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (bc : aborrow_content) : string - = + let aborrow_content_to_string ?(meta : Meta.meta option = None) + (ctx : eval_ctx) (bc : aborrow_content) : string = let env = eval_ctx_to_fmt_env ctx in - aborrow_content_to_string ~meta:meta env bc + aborrow_content_to_string ~meta env bc - let aloan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (lc : aloan_content) : string = + let aloan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (lc : aloan_content) : string = let env = eval_ctx_to_fmt_env ctx in - aloan_content_to_string ~meta:meta env lc + aloan_content_to_string ~meta env lc let aproj_to_string (ctx : eval_ctx) (p : aproj) : string = let env = eval_ctx_to_fmt_env ctx in @@ -566,13 +583,15 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in symbolic_value_to_string env sv - let typed_value_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (v : typed_value) : string = + let typed_value_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (v : typed_value) : string = let env = eval_ctx_to_fmt_env ctx in - typed_value_to_string ~meta:meta env v + typed_value_to_string ~meta env v - let typed_avalue_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (v : typed_avalue) : string = + let typed_avalue_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (v : typed_avalue) : string = let env = eval_ctx_to_fmt_env ctx in - typed_avalue_to_string ~meta:meta env v + typed_avalue_to_string ~meta env v let place_to_string (ctx : eval_ctx) (op : place) : string = let env = eval_ctx_to_fmt_env ctx in @@ -613,13 +632,13 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in trait_impl_to_string env " " " " timpl - let env_elem_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (indent : string) - (indent_incr : string) (ev : env_elem) : string = + let env_elem_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (indent : string) (indent_incr : string) (ev : env_elem) : string = let env = eval_ctx_to_fmt_env ctx in - env_elem_to_string ~meta:meta env false true indent indent_incr ev + env_elem_to_string ~meta env false true indent indent_incr ev - let abs_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (indent : string) (indent_incr : string) - (abs : abs) : string = + let abs_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (indent : string) (indent_incr : string) (abs : abs) : string = let env = eval_ctx_to_fmt_env ctx in - abs_to_string ~meta:meta env false indent indent_incr abs + abs_to_string ~meta env false indent indent_incr abs end diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 6ef87194..1162251a 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -314,17 +314,22 @@ let adt_variant_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) if variant_id = result_return_id then "@Result::Return" else if variant_id = result_fail_id then "@Result::Fail" else - craise_opt_meta meta "Unreachable: improper variant id for result type" + craise_opt_meta meta + "Unreachable: improper variant id for result type" | TError -> let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" - else craise_opt_meta meta "Unreachable: improper variant id for error type" + else + craise_opt_meta meta + "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then "@Fuel::Zero" else if variant_id = fuel_succ_id then "@Fuel::Succ" - else craise_opt_meta meta "Unreachable: improper variant id for fuel type") + else + craise_opt_meta meta + "Unreachable: improper variant id for fuel type") let adt_field_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) (field_id : FieldId.id) : string = @@ -351,9 +356,9 @@ let adt_field_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) (** TODO: we don't need a general function anymore (it is now only used for patterns) *) -let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (value_to_string : 'v -> string) - (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : - string = +let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (value_to_string : 'v -> string) (variant_id : VariantId.id option) + (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in match ty with | TAdt (TTuple, _) -> @@ -398,13 +403,16 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (val | [ v ] -> "@Result::Fail " ^ v | _ -> craise_opt_meta meta "Result::Fail takes exactly one value" else - craise_opt_meta meta "Unreachable: improper variant id for result type" + craise_opt_meta meta + "Unreachable: improper variant id for result type" | TError -> cassert_opt_meta (field_values = []) meta "TODO: error message"; let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" - else craise_opt_meta meta "Unreachable: improper variant id for error type" + else + craise_opt_meta meta + "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then ( @@ -414,7 +422,9 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (val match field_values with | [ v ] -> "@Fuel::Succ " ^ v | _ -> craise_opt_meta meta "@Fuel::Succ takes exactly one value" - else craise_opt_meta meta "Unreachable: improper variant id for fuel type" + else + craise_opt_meta meta + "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr -> cassert_opt_meta (variant_id = None) meta "TODO: error message"; let field_values = @@ -423,13 +433,13 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (val let id = assumed_ty_to_string aty in id ^ " [" ^ String.concat "; " field_values ^ "]") | _ -> - craise_opt_meta - meta - ("Inconsistently typed value: expected ADT type but found:" - ^ "\n- ty: " ^ ty_to_string env false ty ^ "\n- variant_id: " - ^ Print.option_to_string VariantId.to_string variant_id) + craise_opt_meta meta + ("Inconsistently typed value: expected ADT type but found:" ^ "\n- ty: " + ^ ty_to_string env false ty ^ "\n- variant_id: " + ^ Print.option_to_string VariantId.to_string variant_id) -let rec typed_pattern_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_pattern) : string = +let rec typed_pattern_to_string ?(meta : Meta.meta option = None) + (env : fmt_env) (v : typed_pattern) : string = match v.value with | PatConstant cv -> literal_to_string cv | PatVar (v, None) -> var_to_string env v @@ -440,8 +450,8 @@ let rec typed_pattern_to_string ?(meta : Meta.meta option = None) (env : fmt_env ^ ")" | PatDummy -> "_" | PatAdt av -> - adt_g_value_to_string ~meta:meta env - (typed_pattern_to_string ~meta:meta env) + adt_g_value_to_string ~meta env + (typed_pattern_to_string ~meta env) av.variant_id av.field_values v.ty let fun_sig_to_string (env : fmt_env) (sg : fun_sig) : string = @@ -522,8 +532,9 @@ let fun_or_op_id_to_string (env : fmt_env) (fun_id : fun_or_op_id) : string = binop_to_string binop ^ "<" ^ integer_type_to_string int_ty ^ ">" (** [inside]: controls the introduction of parentheses *) -let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) (inside : bool) (indent : string) - (indent_incr : string) (e : texpression) : string = +let rec texpression_to_string ?(metadata : Meta.meta option = None) + (env : fmt_env) (inside : bool) (indent : string) (indent_incr : string) + (e : texpression) : string = match e.e with | Var var_id -> var_id_to_string env var_id | CVar cg_id -> const_generic_var_id_to_string env cg_id @@ -541,10 +552,14 @@ let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_e (* Qualifier without arguments *) app_to_string ~meta:metadata env inside indent indent_incr e [] | Let (monadic, lv, re, e) -> - let e = let_to_string ~meta:metadata env indent indent_incr monadic lv re e in + let e = + let_to_string ~meta:metadata env indent indent_incr monadic lv re e + in if inside then "(" ^ e ^ ")" else e | Switch (scrutinee, body) -> - let e = switch_to_string ~meta:metadata env indent indent_incr scrutinee body in + let e = + switch_to_string ~meta:metadata env indent indent_incr scrutinee body + in if inside then "(" ^ e ^ ")" else e | Loop loop -> let e = loop_to_string ~meta:metadata env indent indent_incr loop in @@ -566,7 +581,8 @@ let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_e (fun (fid, fe) -> let field = FieldId.nth field_names fid in let fe = - texpression_to_string ~metadata:metadata env false indent2 indent_incr fe + texpression_to_string ~metadata env false indent2 indent_incr + fe in "\n" ^ indent1 ^ field ^ " := " ^ fe ^ ";") supd.updates @@ -577,23 +593,23 @@ let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_e let fields = List.map (fun (_, fe) -> - texpression_to_string ~metadata:metadata env false indent2 indent_incr fe) + texpression_to_string ~metadata env false indent2 indent_incr fe) supd.updates in "[ " ^ String.concat ", " fields ^ " ]" | _ -> craise_opt_meta metadata "Unexpected") | Meta (meta, e) -> ( - let meta_s = emeta_to_string ~metadata:metadata env meta in - let e = texpression_to_string ~metadata:metadata env inside indent indent_incr e in + let meta_s = emeta_to_string ~metadata env meta in + let e = texpression_to_string ~metadata env inside indent indent_incr e in match meta with | Assignment _ | SymbolicAssignments _ | SymbolicPlaces _ | Tag _ -> let e = meta_s ^ "\n" ^ indent ^ e in if inside then "(" ^ e ^ ")" else e | MPlace _ -> "(" ^ meta_s ^ " " ^ e ^ ")") -and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bool) (indent : string) - (indent_incr : string) (app : texpression) (args : texpression list) : - string = +and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (inside : bool) (indent : string) (indent_incr : string) (app : texpression) + (args : texpression list) : string = (* There are two possibilities: either the [app] is an instantiated, * top-level qualifier (function, ADT constructore...), or it is a "regular" * expression *) @@ -611,13 +627,13 @@ and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bo (global_decl_id_to_string env global_id, generics) | AdtCons adt_cons_id -> let variant_s = - adt_variant_to_string ~meta:meta env adt_cons_id.adt_id + adt_variant_to_string ~meta env adt_cons_id.adt_id adt_cons_id.variant_id in (ConstStrings.constructor_prefix ^ variant_s, []) | Proj { adt_id; field_id } -> - let adt_s = adt_variant_to_string ~meta:meta env adt_id None in - let field_s = adt_field_to_string ~meta:meta env adt_id field_id in + let adt_s = adt_variant_to_string ~meta env adt_id None in + let field_s = adt_field_to_string ~meta env adt_id field_id in (* Adopting an F*-like syntax *) (ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s, []) | TraitConst (trait_ref, const_name) -> @@ -627,7 +643,8 @@ and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bo | _ -> (* "Regular" expression case *) let inside = args <> [] || (args = [] && inside) in - (texpression_to_string ~metadata:meta env inside indent indent_incr app, []) + ( texpression_to_string ~metadata:meta env inside indent indent_incr app, + [] ) in (* Convert the arguments. * The arguments are expressions, so indentation might get weird... (though @@ -646,31 +663,41 @@ and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bo (* Add parentheses *) if all_args <> [] && inside then "(" ^ e ^ ")" else e -and lambda_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) - (xl : typed_pattern list) (e : texpression) : string = - let xl = List.map (typed_pattern_to_string ~meta:meta env) xl in +and lambda_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (indent : string) (indent_incr : string) (xl : typed_pattern list) + (e : texpression) : string = + let xl = List.map (typed_pattern_to_string ~meta env) xl in let e = texpression_to_string ~metadata:meta env false indent indent_incr e in "λ " ^ String.concat " " xl ^ ". " ^ e -and let_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) - (monadic : bool) (lv : typed_pattern) (re : texpression) (e : texpression) : - string = +and let_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (indent : string) (indent_incr : string) (monadic : bool) + (lv : typed_pattern) (re : texpression) (e : texpression) : string = let indent1 = indent ^ indent_incr in let inside = false in - let re = texpression_to_string ~metadata:meta env inside indent1 indent_incr re in - let e = texpression_to_string ~metadata:meta env inside indent indent_incr e in - let lv = typed_pattern_to_string ~meta:meta env lv in + let re = + texpression_to_string ~metadata:meta env inside indent1 indent_incr re + in + let e = + texpression_to_string ~metadata:meta env inside indent indent_incr e + in + let lv = typed_pattern_to_string ~meta env lv in if monadic then lv ^ " <-- " ^ re ^ ";\n" ^ indent ^ e else "let " ^ lv ^ " = " ^ re ^ " in\n" ^ indent ^ e -and switch_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) - (scrutinee : texpression) (body : switch_body) : string = +and switch_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (indent : string) (indent_incr : string) (scrutinee : texpression) + (body : switch_body) : string = let indent1 = indent ^ indent_incr in (* Printing can mess up on the scrutinee, because it is an expression - but * in most situations it will be a value or a function call, so it should be * ok*) - let scrut = texpression_to_string ~metadata:meta env true indent1 indent_incr scrutinee in - let e_to_string = texpression_to_string ~metadata:meta env false indent1 indent_incr in + let scrut = + texpression_to_string ~metadata:meta env true indent1 indent_incr scrutinee + in + let e_to_string = + texpression_to_string ~metadata:meta env false indent1 indent_incr + in match body with | If (e_true, e_false) -> let e_true = e_to_string e_true in @@ -679,14 +706,14 @@ and switch_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : ^ indent ^ "else\n" ^ indent1 ^ e_false | Match branches -> let branch_to_string (b : match_branch) : string = - let pat = typed_pattern_to_string ~meta:meta env b.pat in + let pat = typed_pattern_to_string ~meta env b.pat in indent ^ "| " ^ pat ^ " ->\n" ^ indent1 ^ e_to_string b.branch in let branches = List.map branch_to_string branches in "match " ^ scrut ^ " with\n" ^ String.concat "\n" branches -and loop_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) - (loop : loop) : string = +and loop_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (indent : string) (indent_incr : string) (loop : loop) : string = let indent1 = indent ^ indent_incr in let indent2 = indent1 ^ indent_incr in let loop_inputs = @@ -696,17 +723,20 @@ and loop_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : s in let output_ty = "output_ty: " ^ ty_to_string env false loop.output_ty in let fun_end = - texpression_to_string ~metadata:meta env false indent2 indent_incr loop.fun_end + texpression_to_string ~metadata:meta env false indent2 indent_incr + loop.fun_end in let loop_body = - texpression_to_string ~metadata:meta env false indent2 indent_incr loop.loop_body + texpression_to_string ~metadata:meta env false indent2 indent_incr + loop.loop_body in "loop {\n" ^ indent1 ^ loop_inputs ^ "\n" ^ indent1 ^ output_ty ^ "\n" ^ indent1 ^ "fun_end: {\n" ^ indent2 ^ fun_end ^ "\n" ^ indent1 ^ "}\n" ^ indent1 ^ "loop_body: {\n" ^ indent2 ^ loop_body ^ "\n" ^ indent1 ^ "}\n" ^ indent ^ "}" -and emeta_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) (meta : emeta) : string = +and emeta_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) + (meta : emeta) : string = let meta = match meta with | Assignment (lp, rv, rp) -> @@ -716,14 +746,14 @@ and emeta_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) (meta | Some rp -> " [@src=" ^ mplace_to_string env rp ^ "]" in "@assign(" ^ mplace_to_string env lp ^ " := " - ^ texpression_to_string ~metadata:metadata env false "" "" rv + ^ texpression_to_string ~metadata env false "" "" rv ^ rp ^ ")" | SymbolicAssignments info -> let infos = List.map (fun (var_id, rv) -> VarId.to_string var_id ^ " == " - ^ texpression_to_string ~metadata:metadata env false "" "" rv) + ^ texpression_to_string ~metadata env false "" "" rv) info in let infos = String.concat ", " infos in @@ -756,5 +786,8 @@ let fun_decl_to_string (env : fmt_env) (def : fun_decl) : string = if inputs = [] then indent else " fun " ^ String.concat " " inputs ^ " ->\n" ^ indent in - let body = texpression_to_string ~metadata:(Some def.meta) env inside indent indent body.body in + let body = + texpression_to_string ~metadata:(Some def.meta) env inside indent indent + body.body + in "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index ab4686c9..e58b318a 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1240,10 +1240,11 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = if List.for_all (fun (_, y) -> y = x) end_args then ( (* We can substitute *) (* Sanity check: all types correct *) - sanity_check ( - List.for_all - (fun (generics1, _) -> generics1 = generics) - args) def.meta; + sanity_check + (List.for_all + (fun (generics1, _) -> generics1 = generics) + args) + def.meta; { e with e = Var x }) else super#visit_texpression env e else super#visit_texpression env e @@ -1398,7 +1399,9 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : { fwd_info; effect_info = loop_fwd_effect_info; ignore_output } in - cassert (fun_sig_info_is_wf loop_fwd_sig_info) def.meta "TODO: error message"; + cassert + (fun_sig_info_is_wf loop_fwd_sig_info) + def.meta "TODO: error message"; let inputs_tys = let fuel = if !Config.use_fuel then [ mk_fuel_ty ] else [] in @@ -1438,9 +1441,10 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : (* Introduce the forward input state *) let fwd_state_var, fwd_state_lvs = - cassert ( - loop_fwd_effect_info.stateful - = Option.is_some loop.input_state) def.meta "TODO: error message"; + cassert + (loop_fwd_effect_info.stateful + = Option.is_some loop.input_state) + def.meta "TODO: error message"; match loop.input_state with | None -> ([], []) | Some input_state -> @@ -1477,7 +1481,8 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : match fuel_vars with | None -> loop.loop_body | Some (fuel0, fuel) -> - SymbolicToPure.wrap_in_match_fuel def.meta fuel0 fuel loop.loop_body + SymbolicToPure.wrap_in_match_fuel def.meta fuel0 fuel + loop.loop_body in let loop_body = { inputs; inputs_lvs; body = loop_body } in diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index d2fa57ae..7576af90 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -9,9 +9,9 @@ open Errors This function should only be used for "regular" ADTs, where the number of fields is fixed: it shouldn't be used for arrays, slices, etc. *) -let get_adt_field_types (meta : Meta.meta) (type_decls : type_decl TypeDeclId.Map.t) - (type_id : type_id) (variant_id : VariantId.id option) - (generics : generic_args) : ty list = +let get_adt_field_types (meta : Meta.meta) + (type_decls : type_decl TypeDeclId.Map.t) (type_id : type_id) + (variant_id : VariantId.id option) (generics : generic_args) : ty list = match type_id with | TTuple -> (* Tuple *) @@ -34,13 +34,13 @@ let get_adt_field_types (meta : Meta.meta) (type_decls : type_decl TypeDeclId.Ma let variant_id = Option.get variant_id in if variant_id = result_return_id then [ ty ] else if variant_id = result_fail_id then [ mk_error_ty ] - else - craise meta "Unreachable: improper variant id for result type" + else craise meta "Unreachable: improper variant id for result type" | TError -> sanity_check (generics = empty_generic_args) meta; let variant_id = Option.get variant_id in - sanity_check ( - variant_id = error_failure_id || variant_id = error_out_of_fuel_id) meta; + sanity_check + (variant_id = error_failure_id || variant_id = error_out_of_fuel_id) + meta; [] | TFuel -> let variant_id = Option.get variant_id in @@ -68,7 +68,8 @@ let check_literal (meta : Meta.meta) (v : literal) (ty : literal_type) : unit = | TBool, VBool _ | TChar, VChar _ -> () | _ -> craise meta "Inconsistent type" -let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = +let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) + (v : typed_pattern) : tc_ctx = log#ldebug (lazy ("check_typed_pattern: " ^ show_typed_pattern v)); match v.value with | PatConstant cv -> @@ -101,7 +102,8 @@ let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) (v : typed_pattern ctx (List.combine field_tys av.field_values) -let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : unit = +let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : + unit = match e.e with | Var var_id -> ( (* Lookup the variable - note that the variable may not be there, @@ -162,7 +164,9 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : sanity_check (generics = qualif.generics) meta | _ -> craise meta "Unreachable")) | Let (monadic, pat, re, e_next) -> - let expected_pat_ty = if monadic then destruct_result meta re.ty else re.ty in + let expected_pat_ty = + if monadic then destruct_result meta re.ty else re.ty + in sanity_check (pat.ty = expected_pat_ty) meta; sanity_check (e.ty = e_next.ty) meta; (* Check the right-expression *) @@ -206,7 +210,8 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : | TAdtId _ -> let variant_id = None in let expected_field_tys = - get_adt_field_types meta ctx.type_decls adt_id variant_id adt_generics + get_adt_field_types meta ctx.type_decls adt_id variant_id + adt_generics in List.iter (fun ((fid, fe) : _ * texpression) -> diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index cce70382..328f757a 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -214,7 +214,8 @@ let fun_sig_substitute (subst : subst) (sg : fun_sig) : inst_fun_sig = Rem.: this function will *fail* if there are {!Pure.Loop} nodes (you should call it on an expression where those nodes have been eliminated). *) -let rec let_group_requires_parentheses (meta : Meta.meta) (e : texpression) : bool = +let rec let_group_requires_parentheses (meta : Meta.meta) (e : texpression) : + bool = match e.e with | Var _ | CVar _ | Const _ | App _ | Qualif _ | StructUpdate _ -> false | Let (monadic, _, _, next_e) -> @@ -321,7 +322,8 @@ let destruct_apps (e : texpression) : texpression * texpression list = aux [] e (** Make an [App (app, arg)] expression *) -let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : texpression = +let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : + texpression = let raise_or_return msg = save_error (Some meta) msg; let e = App (app, arg) in @@ -343,7 +345,8 @@ let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : texpress | _ -> raise_or_return "Expected an arrow type" (** The reverse of {!destruct_apps} *) -let mk_apps (meta : Meta.meta) (app : texpression) (args : texpression list) : texpression = +let mk_apps (meta : Meta.meta) (app : texpression) (args : texpression list) : + texpression = List.fold_left (fun app arg -> mk_app meta app arg) app args (** Destruct an expression into a qualif identifier and a list of arguments, @@ -375,7 +378,8 @@ let opt_destruct_result (meta : Meta.meta) (ty : ty) : ty option = Some (Collections.List.to_cons_nil generics.types) | _ -> None -let destruct_result (meta : Meta.meta) (ty : ty) : ty = Option.get (opt_destruct_result meta ty) +let destruct_result (meta : Meta.meta) (ty : ty) : ty = + Option.get (opt_destruct_result meta ty) let opt_destruct_tuple (meta : Meta.meta) (ty : ty) : ty list option = match ty with @@ -422,7 +426,8 @@ let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : f e_else | Match branches -> List.iter (fun (b : match_branch) -> f b.branch) branches -let mk_switch (meta : Meta.meta) (scrut : texpression) (sb : switch_body) : texpression = +let mk_switch (meta : Meta.meta) (scrut : texpression) (sb : switch_body) : + texpression = (* Sanity check: the scrutinee has the proper type *) (match sb with | If (_, _) -> sanity_check (scrut.ty = TLiteral TBool) meta @@ -497,7 +502,8 @@ let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = { value; ty } (** Similar to {!mk_simpl_tuple_pattern} *) -let mk_simpl_tuple_texpression (meta : Meta.meta) (vl : texpression list) : texpression = +let mk_simpl_tuple_texpression (meta : Meta.meta) (vl : texpression list) : + texpression = match vl with | [ v ] -> v | _ -> @@ -548,7 +554,8 @@ let unwrap_result_ty (meta : Meta.meta) (ty : ty) : ty = ty | _ -> craise meta "not a result type" -let mk_result_fail_texpression (meta : Meta.meta) (error : texpression) (ty : ty) : texpression = +let mk_result_fail_texpression (meta : Meta.meta) (error : texpression) + (ty : ty) : texpression = let type_args = [ ty ] in let ty = TAdt (TAssumed TResult, mk_generic_args_from_types type_args) in let id = @@ -560,12 +567,13 @@ let mk_result_fail_texpression (meta : Meta.meta) (error : texpression) (ty : ty let cons = { e = cons_e; ty = cons_ty } in mk_app meta cons error -let mk_result_fail_texpression_with_error_id (meta : Meta.meta) (error : VariantId.id) (ty : ty) : - texpression = +let mk_result_fail_texpression_with_error_id (meta : Meta.meta) + (error : VariantId.id) (ty : ty) : texpression = let error = mk_error error in mk_result_fail_texpression meta error ty -let mk_result_return_texpression (meta : Meta.meta) (v : texpression) : texpression = +let mk_result_return_texpression (meta : Meta.meta) (v : texpression) : + texpression = let type_args = [ v.ty ] in let ty = TAdt (TAssumed TResult, mk_generic_args_from_types type_args) in let id = @@ -613,15 +621,17 @@ let mk_fuel_var (id : VarId.id) : var = let mk_fuel_texpression (id : VarId.id) : texpression = { e = Var id; ty = mk_fuel_ty } -let rec typed_pattern_to_texpression (meta : Meta.meta) (pat : typed_pattern) : texpression option - = +let rec typed_pattern_to_texpression (meta : Meta.meta) (pat : typed_pattern) : + texpression option = let e_opt = match pat.value with | PatConstant pv -> Some (Const pv) | PatVar (v, _) -> Some (Var v.id) | PatDummy -> None | PatAdt av -> - let fields = List.map (typed_pattern_to_texpression meta) av.field_values in + let fields = + List.map (typed_pattern_to_texpression meta) av.field_values + in if List.mem None fields then None else let fields_values = List.map (fun e -> Option.get e) fields in diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index a4d66854..7267dd3d 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -40,7 +40,8 @@ module Subst = Substitute (** The local logger *) let log = Logging.regions_hierarchy_log -let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : type_decl TypeDeclId.Map.t) +let compute_regions_hierarchy_for_sig (meta : Meta.meta option) + (type_decls : type_decl TypeDeclId.Map.t) (fun_decls : fun_decl FunDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) @@ -51,11 +52,11 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty associated types) *) let norm_ctx : AssociatedTypes.norm_ctx = let norm_trait_types = - AssociatedTypes.compute_norm_trait_types_from_preds meta + AssociatedTypes.compute_norm_trait_types_from_preds meta sg.preds.trait_type_constraints in { - meta = meta; + meta; norm_trait_types; type_decls; fun_decls; @@ -174,13 +175,15 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty | TTraitType (trait_ref, _) -> (* The trait should reference a clause, and not an implementation (otherwise it should have been normalized) *) - sanity_check_opt_meta ( - AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id) meta; + sanity_check_opt_meta + (AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id) + meta; (* We have nothing to do *) () | TArrow (regions, inputs, output) -> (* TODO: *) - cassert_opt_meta (regions = []) meta "We don't support arrow types with locally quantified regions"; + cassert_opt_meta (regions = []) meta + "We don't support arrow types with locally quantified regions"; (* We can ignore the outer regions *) List.iter (explore_ty []) (output :: inputs) and explore_generics (outer : region list) (generics : generic_args) = @@ -319,7 +322,8 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) let regular = List.map (fun ((fid, d) : FunDeclId.id * fun_decl) -> - (FRegular fid, (Types.name_to_string env d.name, d.signature, Some d.meta))) + ( FRegular fid, + (Types.name_to_string env d.name, d.signature, Some d.meta) )) (FunDeclId.Map.bindings fun_decls) in let assumed = @@ -332,6 +336,6 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) (List.map (fun (fid, (name, sg, meta)) -> ( fid, - compute_regions_hierarchy_for_sig meta type_decls fun_decls global_decls - trait_decls trait_impls name sg)) + compute_regions_hierarchy_for_sig meta type_decls fun_decls + global_decls trait_decls trait_impls name sg )) (regular @ assumed)) diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 14cda863..182dfabf 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -68,14 +68,16 @@ let ctx_adt_get_instantiated_field_types (ctx : eval_ctx) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_value_get_instantiated_field_types (meta : Meta.meta) (ctx : eval_ctx) - (adt : adt_value) (id : type_id) (generics : generic_args) : ty list = +let ctx_adt_value_get_instantiated_field_types (meta : Meta.meta) + (ctx : eval_ctx) (adt : adt_value) (id : type_id) (generics : generic_args) + : ty list = match id with | TAdtId id -> (* Retrieve the types of the fields *) ctx_adt_get_instantiated_field_types ctx id adt.variant_id generics | TTuple -> - cassert (generics.regions = []) meta "Regions should be empty TODO: error message"; + cassert (generics.regions = []) meta + "Regions should be empty TODO: error message"; generics.types | TAssumed aty -> ( match aty with @@ -145,7 +147,8 @@ let subst_ids_visitor (r_subst : RegionId.id -> RegionId.id) method! visit_abstraction_id _ id = asubst id end -let typed_value_subst_ids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) +let typed_value_subst_ids (meta : Meta.meta) + (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> TypeVarId.id) (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ssubst : SymbolicValueId.id -> SymbolicValueId.id) @@ -154,8 +157,8 @@ let typed_value_subst_ids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId. let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_value () v -let typed_value_subst_rids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) - (v : typed_value) : typed_value = +let typed_value_subst_rids (meta : Meta.meta) + (r_subst : RegionId.id -> RegionId.id) (v : typed_value) : typed_value = typed_value_subst_ids meta r_subst (fun x -> x) (fun x -> x) @@ -163,7 +166,8 @@ let typed_value_subst_rids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId (fun x -> x) v -let typed_avalue_subst_ids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) +let typed_avalue_subst_ids (meta : Meta.meta) + (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> TypeVarId.id) (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ssubst : SymbolicValueId.id -> SymbolicValueId.id) @@ -190,8 +194,8 @@ let env_subst_ids (r_subst : RegionId.id -> RegionId.id) let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_env () x -let typed_avalue_subst_rids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) - (x : typed_avalue) : typed_avalue = +let typed_avalue_subst_rids (meta : Meta.meta) + (r_subst : RegionId.id -> RegionId.id) (x : typed_avalue) : typed_avalue = let asubst _ = craise meta "Unreachable" in let vis = subst_ids_visitor r_subst diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 3532b2dd..db32c2ce 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -349,7 +349,8 @@ let pure_type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.texpression_to_string ~metadata:(Some ctx.fun_decl.meta) env false "" " " e + PrintPure.texpression_to_string ~metadata:(Some ctx.fun_decl.meta) env false + "" " " e let fun_id_to_string (ctx : bs_ctx) (id : A.fun_id) : string = let env = bs_ctx_to_fmt_env ctx in @@ -363,9 +364,10 @@ let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = let env = bs_ctx_to_pure_fmt_env ctx in PrintPure.fun_decl_to_string env def -let typed_pattern_to_string ?(meta : Meta.meta option = None) (ctx : bs_ctx) (p : Pure.typed_pattern) : string = +let typed_pattern_to_string ?(meta : Meta.meta option = None) (ctx : bs_ctx) + (p : Pure.typed_pattern) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.typed_pattern_to_string ~meta:meta env p + PrintPure.typed_pattern_to_string ~meta env p let ctx_get_effect_info_for_bid (ctx : bs_ctx) (bid : RegionGroupId.id option) : fun_effect_info = @@ -384,7 +386,8 @@ let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = let verbose = false in let indent = "" in let indent_incr = " " in - Print.Values.abs_to_string ~meta:(Some ctx.fun_decl.meta) env verbose indent indent_incr abs + Print.Values.abs_to_string ~meta:(Some ctx.fun_decl.meta) env verbose indent + indent_incr abs let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : T.type_decl = @@ -407,8 +410,8 @@ let rec translate_generic_args (meta : Meta.meta) (translate_ty : T.ty -> ty) in { types; const_generics; trait_refs } -and translate_trait_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) (tr : T.trait_ref) : - trait_ref = +and translate_trait_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) + (tr : T.trait_ref) : trait_ref = let trait_id = translate_trait_instance_id meta translate_ty tr.trait_id in let generics = translate_generic_args meta translate_ty tr.generics in let trait_decl_ref = @@ -416,14 +419,18 @@ and translate_trait_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) (tr : T.t in { trait_id; generics; trait_decl_ref } -and translate_trait_decl_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) (tr : T.trait_decl_ref) - : trait_decl_ref = - let decl_generics = translate_generic_args meta translate_ty tr.decl_generics in +and translate_trait_decl_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) + (tr : T.trait_decl_ref) : trait_decl_ref = + let decl_generics = + translate_generic_args meta translate_ty tr.decl_generics + in { trait_decl_id = tr.trait_decl_id; decl_generics } and translate_trait_instance_id (meta : Meta.meta) (translate_ty : T.ty -> ty) (id : T.trait_instance_id) : trait_instance_id = - let translate_trait_instance_id = translate_trait_instance_id meta translate_ty in + let translate_trait_instance_id = + translate_trait_instance_id meta translate_ty + in match id with | T.Self -> Self | TraitImpl id -> TraitImpl id @@ -459,10 +466,8 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = match generics.types with | [ ty ] -> ty | _ -> - craise - meta - "Box/vec/option type with incorrect number of arguments" - ) + craise meta + "Box/vec/option type with incorrect number of arguments") | T.TArray -> TAdt (TAssumed TArray, generics) | T.TSlice -> TAdt (TAssumed TSlice, generics) | T.TStr -> TAdt (TAssumed TStr, generics))) @@ -480,35 +485,41 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = TTraitType (trait_ref, type_name) | TArrow _ -> craise meta "TODO: error message" -and translate_sgeneric_args (meta : Meta.meta) (generics : T.generic_args) : generic_args = +and translate_sgeneric_args (meta : Meta.meta) (generics : T.generic_args) : + generic_args = translate_generic_args meta (translate_sty meta) generics and translate_strait_ref (meta : Meta.meta) (tr : T.trait_ref) : trait_ref = translate_trait_ref meta (translate_sty meta) tr -and translate_strait_instance_id (meta : Meta.meta) (id : T.trait_instance_id) : trait_instance_id - = +and translate_strait_instance_id (meta : Meta.meta) (id : T.trait_instance_id) : + trait_instance_id = translate_trait_instance_id meta (translate_sty meta) id -let translate_trait_clause (meta : Meta.meta) (clause : T.trait_clause) : trait_clause = +let translate_trait_clause (meta : Meta.meta) (clause : T.trait_clause) : + trait_clause = let { T.clause_id; meta = _; trait_id; clause_generics } = clause in let generics = translate_sgeneric_args meta clause_generics in { clause_id; trait_id; generics } -let translate_strait_type_constraint (meta : Meta.meta) (ttc : T.trait_type_constraint) : - trait_type_constraint = +let translate_strait_type_constraint (meta : Meta.meta) + (ttc : T.trait_type_constraint) : trait_type_constraint = let { T.trait_ref; type_name; ty } = ttc in let trait_ref = translate_strait_ref meta trait_ref in let ty = translate_sty meta ty in { trait_ref; type_name; ty } -let translate_predicates (meta : Meta.meta) (preds : T.predicates) : predicates = +let translate_predicates (meta : Meta.meta) (preds : T.predicates) : predicates + = let trait_type_constraints = - List.map (translate_strait_type_constraint meta) preds.trait_type_constraints + List.map + (translate_strait_type_constraint meta) + preds.trait_type_constraints in { trait_type_constraints } -let translate_generic_params (meta : Meta.meta) (generics : T.generic_params) : generic_params = +let translate_generic_params (meta : Meta.meta) (generics : T.generic_params) : + generic_params = let { T.regions = _; types; const_generics; trait_clauses } = generics in let trait_clauses = List.map (translate_trait_clause meta) trait_clauses in { types; const_generics; trait_clauses } @@ -530,7 +541,8 @@ let translate_variants (meta : Meta.meta) (vl : T.variant list) : variant list = List.map (translate_variant meta) vl (** Translate a type def kind from LLBC *) -let translate_type_decl_kind (meta : Meta.meta) (kind : T.type_decl_kind) : type_decl_kind = +let translate_type_decl_kind (meta : Meta.meta) (kind : T.type_decl_kind) : + type_decl_kind = match kind with | T.Struct fields -> Struct (translate_fields meta fields) | T.Enum variants -> Enum (translate_variants meta variants) @@ -555,8 +567,11 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : let name = Print.Types.name_to_string env def.name in let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) - cassert (regions = []) def.meta "ADTs containing borrows are not supported yet"; - let trait_clauses = List.map (translate_trait_clause def.meta) trait_clauses in + cassert (regions = []) def.meta + "ADTs containing borrows are not supported yet"; + let trait_clauses = + List.map (translate_trait_clause def.meta) trait_clauses + in let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.meta def.T.kind in let preds = translate_predicates def.meta def.preds in @@ -599,7 +614,8 @@ let translate_type_id (meta : Meta.meta) (id : T.type_id) : type_id = TODO: factor out the various translation functions. *) -let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) (ty : T.ty) : ty = +let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) + (ty : T.ty) : ty = let translate = translate_fwd_ty meta type_infos in match ty with | T.TAdt (type_id, generics) -> ( @@ -616,18 +632,18 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) (ty : T.ty | TAssumed TBox -> ( (* We eliminate boxes *) (* No general parametricity for now *) - cassert ( - not - (List.exists - (TypesUtils.ty_has_borrows type_infos) - generics.types)) meta "ADTs containing borrows are not supported yet"; + cassert + (not + (List.exists + (TypesUtils.ty_has_borrows type_infos) + generics.types)) + meta "ADTs containing borrows are not supported yet"; match t_generics.types with | [ bty ] -> bty | _ -> - craise - meta - "Unreachable: box/vec/option receives exactly one type \ - parameter")) + craise meta + "Unreachable: box/vec/option receives exactly one type \ + parameter")) | TVar vid -> TVar vid | TNever -> craise meta "Unreachable" | TLiteral lty -> TLiteral lty @@ -646,8 +662,8 @@ and translate_fwd_generic_args (meta : Meta.meta) (type_infos : type_infos) (generics : T.generic_args) : generic_args = translate_generic_args meta (translate_fwd_ty meta type_infos) generics -and translate_fwd_trait_ref (meta : Meta.meta) (type_infos : type_infos) (tr : T.trait_ref) : - trait_ref = +and translate_fwd_trait_ref (meta : Meta.meta) (type_infos : type_infos) + (tr : T.trait_ref) : trait_ref = translate_trait_ref meta (translate_fwd_ty meta type_infos) tr and translate_fwd_trait_instance_id (meta : Meta.meta) (type_infos : type_infos) @@ -685,7 +701,9 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) if inside_mut then (* We do not want to filter anything, so we translate the generics as "forward" types *) - let generics = translate_fwd_generic_args meta type_infos generics in + let generics = + translate_fwd_generic_args meta type_infos generics + in Some (TAdt (type_id, generics)) else (* If not inside a mutable reference: check if at least one @@ -696,19 +714,22 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) *) let types = List.filter_map translate generics.types in if types <> [] then - let generics = translate_fwd_generic_args meta type_infos generics in + let generics = + translate_fwd_generic_args meta type_infos generics + in Some (TAdt (type_id, generics)) else None | TAssumed TBox -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) - cassert (not (TypesUtils.ty_has_borrows type_infos ty)) meta "ADTs containing borrows are not supported yet"; + cassert + (not (TypesUtils.ty_has_borrows type_infos ty)) + meta "ADTs containing borrows are not supported yet"; (* Eliminate the box *) match generics.types with | [ bty ] -> translate bty | _ -> - craise - meta "Unreachable: boxes receive exactly one type parameter" - ) + craise meta + "Unreachable: boxes receive exactly one type parameter") | TTuple -> ( (* Tuples can contain borrows (which we eliminate) *) let tys_t = List.filter_map translate generics.types in @@ -786,7 +807,9 @@ let translate_fun_id_or_trait_method_ref (ctx : bs_ctx) | FunId fun_id -> FunId fun_id | TraitMethod (trait_ref, method_name, fun_decl_id) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref in + let trait_ref = + translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref + in TraitMethod (trait_ref, method_name, fun_decl_id) let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) @@ -816,7 +839,9 @@ let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) let calls = V.FunCallId.Map.add call_id info ctx.calls in (* Insert the abstraction in the abstractions map *) let abstractions = ctx.abstractions in - sanity_check (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) ctx.fun_decl.meta; + sanity_check + (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) + ctx.fun_decl.meta; let abstractions = V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions in @@ -878,7 +903,8 @@ let mk_fuel_input_as_list (ctx : bs_ctx) (info : fun_effect_info) : if function_uses_fuel info then [ mk_fuel_texpression ctx.fuel ] else [] (** Small utility. *) -let compute_raw_fun_effect_info (meta : Meta.meta) (fun_infos : fun_info A.FunDeclId.Map.t) +let compute_raw_fun_effect_info (meta : Meta.meta) + (fun_infos : fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with @@ -921,7 +947,8 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) in { info with is_rec = info.is_rec || Option.is_some lid } | FunId (FAssumed _) -> - compute_raw_fun_effect_info ctx.fun_decl.meta ctx.fun_ctx.fun_infos fun_id lid gid) + compute_raw_fun_effect_info ctx.fun_decl.meta ctx.fun_ctx.fun_infos + fun_id lid gid) | Some lid -> ( (* This is necessarily for the current function *) match fun_id with @@ -1031,7 +1058,9 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) (* For now we don't supported nested borrows, so we check that there aren't parent regions *) let parents = list_ancestor_region_groups regions_hierarchy gid in - cassert (T.RegionGroupId.Set.is_empty parents) meta "Nested borrows are not supported yet"; + cassert + (T.RegionGroupId.Set.is_empty parents) + meta "Nested borrows are not supported yet"; (* For now, we don't allow nested borrows, so the additional inputs to the backward function can only come from borrows that were returned like in (for the backward function we introduce for 'a): @@ -1477,13 +1506,13 @@ let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = match V.SymbolicValueId.Map.find_opt sv.sv_id ctx.sv_to_var with | Some v -> v | None -> - craise - ctx.fun_decl.meta - ("Could not find var for symbolic value: " - ^ V.SymbolicValueId.to_string sv.sv_id) + craise ctx.fun_decl.meta + ("Could not find var for symbolic value: " + ^ V.SymbolicValueId.to_string sv.sv_id) (** Peel boxes as long as the value is of the form [Box] *) -let rec unbox_typed_value (meta : Meta.meta) (v : V.typed_value) : V.typed_value = +let rec unbox_typed_value (meta : Meta.meta) (v : V.typed_value) : V.typed_value + = match (v.value, v.ty) with | V.VAdt av, T.TAdt (T.TAssumed T.TBox, _) -> ( match av.field_values with @@ -1567,13 +1596,19 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) match bc with | VSharedBorrow bid -> (* Lookup the shared value in the context, and continue *) - let sv = InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx bid in + let sv = + InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx + bid + in translate sv | VReservedMutBorrow bid -> (* Same as for shared borrows. However, note that we use reserved borrows * only in *meta-data*: a value *actually used* in the translation can't come * from an unpromoted reserved borrow *) - let sv = InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx bid in + let sv = + InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx + bid + in translate sv | VMutBorrow (_, v) -> (* Borrows are the identity in the extraction *) @@ -1619,7 +1654,8 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert (field_values = []) ctx.fun_decl.meta "ADTs containing borrows are not supported yet"; + cassert (field_values = []) ctx.fun_decl.meta + "ADTs containing borrows are not supported yet"; None | TTuple -> (* Return *) @@ -1627,7 +1663,9 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) else (* Note that if there is exactly one field value, * [mk_simpl_tuple_rvalue] is the identity *) - let rv = mk_simpl_tuple_texpression ctx.fun_decl.meta field_values in + let rv = + mk_simpl_tuple_texpression ctx.fun_decl.meta field_values + in Some rv) | ABottom -> craise ctx.fun_decl.meta "Unreachable" | ALoan lc -> aloan_content_to_consumed ctx ectx lc @@ -1646,7 +1684,8 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (lc : V.aloan_content) : texpression option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise ctx.fun_decl.meta "Unreachable" + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> + craise ctx.fun_decl.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> (* Return the meta-value *) Some (typed_value_to_texpression ctx ectx given_back_meta) @@ -1762,7 +1801,8 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert (field_values = []) ctx.fun_decl.meta "ADTs with borrows are not supported yet"; + cassert (field_values = []) ctx.fun_decl.meta + "ADTs with borrows are not supported yet"; (ctx, None) | TTuple -> (* Return *) @@ -1789,7 +1829,8 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise ctx.fun_decl.meta "Unreachable" + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> + craise ctx.fun_decl.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } | AEndedSharedLoan (_, _) -> (* We consider given back values, and thus ignore those *) @@ -1826,10 +1867,11 @@ and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : | V.AEndedProjLoans (_, child_projs) -> (* There may be children borrow projections in case of nested borrows, * in which case we need to dive in - we disallow nested borrows for now *) - cassert ( - List.for_all - (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) - child_projs) ctx.fun_decl.meta "Nested borrows are not supported yet"; + cassert + (List.for_all + (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) + child_projs) + ctx.fun_decl.meta "Nested borrows are not supported yet"; (ctx, None) | AEndedProjBorrows mv -> (* Return the meta-value *) @@ -1960,10 +2002,13 @@ and translate_panic (ctx : bs_ctx) : texpression = (* Create the [Fail] value *) let ret_ty = mk_simpl_tuple_ty [ mk_state_ty; output_ty ] in let ret_v = - mk_result_fail_texpression_with_error_id ctx.fun_decl.meta error_failure_id ret_ty + mk_result_fail_texpression_with_error_id ctx.fun_decl.meta + error_failure_id ret_ty in ret_v - else mk_result_fail_texpression_with_error_id ctx.fun_decl.meta error_failure_id output_ty + else + mk_result_fail_texpression_with_error_id ctx.fun_decl.meta + error_failure_id output_ty in if ctx.inside_loop && Option.is_some ctx.bid then (* We are synthesizing the backward function of a loop body *) @@ -2086,7 +2131,8 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) else output in (* Wrap in a result - TODO: check effect_info.can_fail to not always wrap *) - mk_emeta (Tag "return_with_loop") (mk_result_return_texpression ctx.fun_decl.meta output) + mk_emeta (Tag "return_with_loop") + (mk_result_return_texpression ctx.fun_decl.meta output) and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : texpression = @@ -2137,8 +2183,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let sg = Option.get call.sg in let decls_ctx = ctx.decls_ctx in let dsg = - translate_fun_sig_with_regions_hierarchy_to_decomposed ctx.fun_decl.meta decls_ctx fid - call.regions_hierarchy sg + translate_fun_sig_with_regions_hierarchy_to_decomposed + ctx.fun_decl.meta decls_ctx fid call.regions_hierarchy sg (List.map (fun _ -> None) sg.inputs) in log#ldebug @@ -2151,8 +2197,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : ctx_translate_fwd_generic_args ctx all_generics in let tr_self = - translate_fwd_trait_instance_id ctx.fun_decl.meta ctx.type_ctx.type_infos - tr_self + translate_fwd_trait_instance_id ctx.fun_decl.meta + ctx.type_ctx.type_infos tr_self in (tr_self, all_generics) in @@ -2368,8 +2414,9 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) ^ T.RegionGroupId.to_string rg_id ^ "\n- loop_id: " ^ Print.option_to_string Pure.LoopId.to_string ctx.loop_id - ^ "\n- eval_ctx:\n" ^ eval_ctx_to_string ~meta:(Some ctx.fun_decl.meta) ectx ^ "\n- abs:\n" - ^ abs_to_string ctx abs ^ "\n")); + ^ "\n- eval_ctx:\n" + ^ eval_ctx_to_string ~meta:(Some ctx.fun_decl.meta) ectx + ^ "\n- abs:\n" ^ abs_to_string ctx abs ^ "\n")); (* When we end an input abstraction, this input abstraction gets back the borrows which it introduced in the context through the input @@ -2429,7 +2476,8 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) (* TODO: normalize the types *) if !Config.type_check_pure_code then List.iter - (fun (var, v) -> sanity_check ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta) + (fun (var, v) -> + sanity_check ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta) variables_values; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2566,7 +2614,8 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) (* Retrieve the values consumed upon ending the loans inside this * abstraction: as there are no nested borrows, there should be none. *) let consumed = abs_to_consumed ctx ectx abs in - cassert (consumed = []) ctx.fun_decl.meta "Nested borrows are not supported yet"; + cassert (consumed = []) ctx.fun_decl.meta + "Nested borrows are not supported yet"; (* Retrieve the values given back upon ending this abstraction - note that * we don't provide meta-place information, because those assignments will * be inlined anyway... *) @@ -2799,7 +2848,9 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) let branch = List.hd branches in let ty = branch.branch.ty in (* Sanity check *) - sanity_check (List.for_all (fun br -> br.branch.ty = ty) branches) ctx.fun_decl.meta; + sanity_check + (List.for_all (fun br -> br.branch.ty = ty) branches) + ctx.fun_decl.meta; (* Return *) { e; ty }) | ExpandBool (true_e, false_e) -> @@ -2819,7 +2870,8 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) ^ pure_ty_to_string ctx true_e.ty ^ "\n\nfalse_e.ty: " ^ pure_ty_to_string ctx false_e.ty)); - save_error ~b:(ty = false_e.ty) (Some ctx.fun_decl.meta) "Internal error, please file an issue"; + save_error ~b:(ty = false_e.ty) (Some ctx.fun_decl.meta) + "Internal error, please file an issue"; { e; ty } | ExpandInt (int_ty, branches, otherwise) -> let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : @@ -2844,8 +2896,9 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) Match all_branches ) in let ty = otherwise.branch.ty in - sanity_check ( - List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) ctx.fun_decl.meta; + sanity_check + (List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) + ctx.fun_decl.meta; { e; ty } (* Translate and [ExpandAdt] when there is no branching (i.e., one branch). @@ -2946,7 +2999,9 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) | TAssumed TBox -> (* There should be exactly one variable *) let var = - match vars with [ v ] -> v | _ -> craise ctx.fun_decl.meta "Unreachable" + match vars with + | [ v ] -> v + | _ -> craise ctx.fun_decl.meta "Unreachable" in (* We simply introduce an assignment - the box type is the * identity when extracted ([box a = a]) *) @@ -2997,7 +3052,9 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) | VaCgValue cg_id -> { e = CVar cg_id; ty = var.ty } | VaTraitConstValue (trait_ref, const_name) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref in + let trait_ref = + translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref + in let qualif_id = TraitConst (trait_ref, const_name) in let qualif = { id = qualif_id; generics = empty_generic_args } in { e = Qualif qualif; ty = var.ty } @@ -3149,7 +3206,9 @@ and translate_forward_end (ectx : C.eval_ctx) in let state_var = List.map mk_texpression_from_var state_var in - let ret = mk_simpl_tuple_texpression ctx.fun_decl.meta (state_var @ [ ret ]) in + let ret = + mk_simpl_tuple_texpression ctx.fun_decl.meta (state_var @ [ ret ]) + in let ret = mk_result_return_texpression ctx.fun_decl.meta ret in (* Introduce all the let-bindings *) @@ -3377,11 +3436,12 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = in (* Sanity check: all the non-fresh symbolic values are in the context *) - sanity_check ( - List.for_all - (fun (sv : V.symbolic_value) -> - V.SymbolicValueId.Map.mem sv.sv_id ctx.sv_to_var) - loop.input_svalues) ctx.fun_decl.meta; + sanity_check + (List.for_all + (fun (sv : V.symbolic_value) -> + V.SymbolicValueId.Map.mem sv.sv_id ctx.sv_to_var) + loop.input_svalues) + ctx.fun_decl.meta; (* Translate the loop inputs *) let inputs = @@ -3401,7 +3461,9 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* The types shouldn't contain borrows - we can translate them as forward types *) List.map (fun ty -> - cassert (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)) !ctx.fun_decl.meta "The types shouldn't contain borrows"; + cassert + (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)) + !ctx.fun_decl.meta "The types shouldn't contain borrows"; ctx_translate_fwd_ty !ctx ty) tys) loop.rg_to_given_back_tys @@ -3589,8 +3651,8 @@ and translate_emeta (meta : S.emeta) (e : S.expression) (ctx : bs_ctx) : | None -> next_e (** Wrap a function body in a match over the fuel to control termination. *) -let wrap_in_match_fuel (meta : Meta.meta) (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) - : texpression = +let wrap_in_match_fuel (meta : Meta.meta) (fuel0 : VarId.id) (fuel : VarId.id) + (body : texpression) : texpression = let fuel0_var : var = mk_fuel_var fuel0 in let fuel0 = mk_texpression_from_var fuel0_var in let nfuel_var : var = mk_fuel_var fuel in @@ -3736,10 +3798,11 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (List.map (pure_ty_to_string ctx) signature.inputs))); (* TODO: we need to normalize the types *) if !Config.type_check_pure_code then - sanity_check ( - List.for_all - (fun (var, ty) -> (var : var).ty = ty) - (List.combine inputs signature.inputs)) def.meta; + sanity_check + (List.for_all + (fun (var, ty) -> (var : var).ty = ty) + (List.combine inputs signature.inputs)) + def.meta; Some { inputs; inputs_lvs; body } in @@ -3803,10 +3866,13 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) in let generics = translate_generic_params trait_decl.meta llbc_generics in let preds = translate_predicates trait_decl.meta preds in - let parent_clauses = List.map (translate_trait_clause trait_decl.meta) llbc_parent_clauses in + let parent_clauses = + List.map (translate_trait_clause trait_decl.meta) llbc_parent_clauses + in let consts = List.map - (fun (name, (ty, id)) -> (name, (translate_fwd_ty trait_decl.meta type_infos ty, id))) + (fun (name, (ty, id)) -> + (name, (translate_fwd_ty trait_decl.meta type_infos ty, id))) consts in let types = @@ -3854,7 +3920,9 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) in let type_infos = ctx.type_ctx.type_infos in let impl_trait = - translate_trait_decl_ref trait_impl.meta (translate_fwd_ty trait_impl.meta type_infos) llbc_impl_trait + translate_trait_decl_ref trait_impl.meta + (translate_fwd_ty trait_impl.meta type_infos) + llbc_impl_trait in let name = Print.Types.name_to_string @@ -3863,17 +3931,22 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) in let generics = translate_generic_params trait_impl.meta llbc_generics in let preds = translate_predicates trait_impl.meta preds in - let parent_trait_refs = List.map (translate_strait_ref trait_impl.meta) parent_trait_refs in + let parent_trait_refs = + List.map (translate_strait_ref trait_impl.meta) parent_trait_refs + in let consts = List.map - (fun (name, (ty, id)) -> (name, (translate_fwd_ty trait_impl.meta type_infos ty, id))) + (fun (name, (ty, id)) -> + (name, (translate_fwd_ty trait_impl.meta type_infos ty, id))) consts in let types = List.map (fun (name, (trait_refs, ty)) -> ( name, - ( List.map (translate_fwd_trait_ref trait_impl.meta type_infos) trait_refs, + ( List.map + (translate_fwd_trait_ref trait_impl.meta type_infos) + trait_refs, translate_fwd_ty trait_impl.meta type_infos ty ) )) types in diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index bdd27d0f..f7437f7e 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -6,22 +6,26 @@ open LlbcAst open SymbolicAst open Errors -let mk_mplace (meta : Meta.meta) (p : place) (ctx : Contexts.eval_ctx) : mplace = +let mk_mplace (meta : Meta.meta) (p : place) (ctx : Contexts.eval_ctx) : mplace + = let bv = Contexts.ctx_lookup_var_binder meta ctx p.var_id in { bv; projection = p.projection } -let mk_opt_mplace (meta : Meta.meta) (p : place option) (ctx : Contexts.eval_ctx) : mplace option = +let mk_opt_mplace (meta : Meta.meta) (p : place option) + (ctx : Contexts.eval_ctx) : mplace option = Option.map (fun p -> mk_mplace meta p ctx) p -let mk_opt_place_from_op (meta : Meta.meta) (op : operand) (ctx : Contexts.eval_ctx) : - mplace option = - match op with Copy p | Move p -> Some (mk_mplace meta p ctx) | Constant _ -> None +let mk_opt_place_from_op (meta : Meta.meta) (op : operand) + (ctx : Contexts.eval_ctx) : mplace option = + match op with + | Copy p | Move p -> Some (mk_mplace meta p ctx) + | Constant _ -> None let mk_emeta (m : emeta) (e : expression) : expression = Meta (m, e) -let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (place : mplace option) - (seel : symbolic_expansion option list) (el : expression list option) : - expression option = +let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) + (place : mplace option) (seel : symbolic_expansion option list) + (el : expression list option) : expression option = match el with | None -> None | Some el -> @@ -87,9 +91,9 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (plac in Some (Expansion (place, sv, expansion)) -let synthesize_symbolic_expansion_no_branching (meta : Meta.meta) (sv : symbolic_value) - (place : mplace option) (see : symbolic_expansion) (e : expression option) : - expression option = +let synthesize_symbolic_expansion_no_branching (meta : Meta.meta) + (sv : symbolic_value) (place : mplace option) (see : symbolic_expansion) + (e : expression option) : expression option = let el = Option.map (fun e -> [ e ]) e in synthesize_symbolic_expansion meta sv place [ Some see ] el diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 9c4b8b45..d2c48d13 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -15,7 +15,8 @@ let mk_typed_value (meta : Meta.meta) (ty : ty) (value : value) : typed_value = sanity_check (ty_is_ety ty) meta; { value; ty } -let mk_typed_avalue (meta : Meta.meta) (ty : ty) (value : avalue) : typed_avalue = +let mk_typed_avalue (meta : Meta.meta) (ty : ty) (value : avalue) : typed_avalue + = sanity_check (ty_is_rty ty) meta; { value; ty } @@ -51,7 +52,8 @@ let is_symbolic (v : value) : bool = let as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = match v with VSymbolic s -> s | _ -> craise meta "Unexpected" -let as_mut_borrow (meta : Meta.meta) (v : typed_value) : BorrowId.id * typed_value = +let as_mut_borrow (meta : Meta.meta) (v : typed_value) : + BorrowId.id * typed_value = match v.value with | VBorrow (VMutBorrow (bid, bv)) -> (bid, bv) | _ -> craise meta "Unexpected" -- cgit v1.2.3 From 4eac16f0954ab037413c24a69799a9d595f920f2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 28 Mar 2024 17:17:42 +0100 Subject: Revert some changes which shouldn't be here --- compiler/ExtractBase.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index b7255dbc..99167ae4 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -237,7 +237,7 @@ module IdSet = Collections.MakeSet (IdOrderedType) *) type names_map = { id_to_name : string IdMap.t; - name_to_id : (id * Meta.meta option) StringMap.t; + name_to_id : id StringMap.t; (** The name to id map is used to look for name clashes, and generate nice debugging messages: if there is a name clash, it is useful to know precisely which identifiers are mapped to the same name... @@ -253,8 +253,8 @@ let empty_names_map : names_map = } (** Small helper to report name collision *) -let report_name_collision (id_to_string : id -> string) - ((id1, meta) : id * Meta.meta option) (id2 : id) (name : string) : unit = +let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) + (name : string) : unit = let id1 = "\n- " ^ id_to_string id1 in let id2 = "\n- " ^ id_to_string id2 in let err = @@ -263,10 +263,9 @@ let report_name_collision (id_to_string : id -> string) ^ "\nYou may want to rename some of your definitions, or report an issue." in (* If we fail hard on errors, raise an exception *) - save_error meta err + save_error None err -let names_map_get_id_from_name (name : string) (nm : names_map) : - (id * meta option) option = +let names_map_get_id_from_name (name : string) (nm : names_map) : id option = StringMap.find_opt name nm.name_to_id let names_map_check_collision (id_to_string : id -> string) (id : id) -- cgit v1.2.3 From c2069900aa534d49b6c07eea8f5ab2fb70a26aa2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 28 Mar 2024 17:25:54 +0100 Subject: Fix an issue --- compiler/Errors.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/Errors.ml b/compiler/Errors.ml index 3b34397a..6057362e 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -40,7 +40,7 @@ let craise_opt_meta (meta : Meta.meta option) (msg : string) = let craise (meta : Meta.meta) (msg : string) = craise_opt_meta (Some meta) msg let cassert_opt_meta (b : bool) (meta : Meta.meta option) (msg : string) = - if b then craise_opt_meta meta msg + if not b then craise_opt_meta meta msg let cassert (b : bool) (meta : Meta.meta) (msg : string) = cassert_opt_meta b (Some meta) msg -- cgit v1.2.3 From 6f4833f84dd3ec17311b5e6ca9f5c1ad94ff7564 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 29 Mar 2024 11:31:47 +0100 Subject: Improve the error messages --- compiler/Errors.ml | 2 +- compiler/Main.ml | 31 +++++++++++++++++++++++-------- compiler/PrePasses.ml | 19 +++++++++++-------- 3 files changed, 35 insertions(+), 17 deletions(-) (limited to 'compiler') diff --git a/compiler/Errors.ml b/compiler/Errors.ml index 6057362e..68073ef7 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -7,7 +7,7 @@ let meta_to_string (span : Meta.span) = ^ loc_to_string span.end_loc let format_error_message (meta : Meta.meta) msg = - msg ^ ":" ^ meta_to_string meta.span + msg ^ "\n" ^ meta_to_string meta.span exception CFailure of string diff --git a/compiler/Main.ml b/compiler/Main.ml index 41addc81..88c32ca9 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -267,16 +267,31 @@ let () = definitions"; fail ()); - (* Apply the pre-passes *) - let m = Aeneas.PrePasses.apply_passes m in + (try + (* Apply the pre-passes *) + let m = Aeneas.PrePasses.apply_passes m in - (* Some options for the execution *) + (* Test the unit functions with the concrete interpreter *) + if !test_unit_functions then Test.test_unit_functions m; - (* Test the unit functions with the concrete interpreter *) - if !test_unit_functions then Test.test_unit_functions m; - - (* Translate the functions *) - Aeneas.Translate.translate_crate filename dest_dir m; + (* Translate the functions *) + Aeneas.Translate.translate_crate filename dest_dir m + with Errors.CFailure msg -> + (* In theory it shouldn't happen, but there may be uncaught errors - + note that we let the Failure errors go through *) + (* The error should have been saved *) + let meta = + match !Errors.error_list with + | (m, _) :: _ -> m + | _ -> (* Want to be safe here *) None + in + let msg = + match meta with + | None -> msg + | Some m -> Errors.format_error_message m msg + in + log#serror msg; + exit 1); (* Print total elapsed time *) log#linfo diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index 42857a88..8c346a8c 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -214,14 +214,17 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = object inherit [_] map_statement as super - method! visit_Loop entered_loop loop = - cassert (not entered_loop) st.meta - "Nested loops are not supported yet"; - super#visit_Loop true loop - - method! visit_Break _ i = - cassert (i = 0) st.meta "Breaks to outer loops are not supported yet"; - nst.content + method! visit_statement entered_loop st = + match st.content with + | Loop loop -> + cassert (not entered_loop) st.meta + "Nested loops are not supported yet"; + { st with content = super#visit_Loop true loop } + | Break i -> + cassert (i = 0) st.meta + "Breaks to outer loops are not supported yet"; + { st with content = nst.content } + | _ -> super#visit_statement entered_loop st end in obj#visit_statement false st -- cgit v1.2.3 From bd89156cbdcb047ed9a6c557e9873dd5724c391f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 29 Mar 2024 11:33:32 +0100 Subject: Make a minor modification --- compiler/Main.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/Main.ml b/compiler/Main.ml index 88c32ca9..798bcec3 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -282,7 +282,10 @@ let () = (* The error should have been saved *) let meta = match !Errors.error_list with - | (m, _) :: _ -> m + | (m, msg') :: _ -> + (* The last saved message should be the current error - but + good to check *) + if msg = msg' then m else None | _ -> (* Want to be safe here *) None in let msg = -- cgit v1.2.3 From 786c54c01ea98580374638c0ed92d19dfae19b1f Mon Sep 17 00:00:00 2001 From: Escherichia Date: Fri, 29 Mar 2024 13:21:08 +0100 Subject: added file and line arg to craise and cassert --- compiler/AssociatedTypes.ml | 16 +- compiler/Contexts.ml | 18 +-- compiler/Errors.ml | 38 ++--- compiler/Extract.ml | 50 +++---- compiler/ExtractBase.ml | 33 +++-- compiler/ExtractName.ml | 2 +- compiler/ExtractTypes.ml | 58 ++++---- compiler/FunsAnalysis.ml | 6 +- compiler/Interpreter.ml | 24 +-- compiler/InterpreterBorrows.ml | 258 ++++++++++++++++----------------- compiler/InterpreterBorrowsCore.ml | 98 ++++++------- compiler/InterpreterExpansion.ml | 52 +++---- compiler/InterpreterExpressions.ml | 104 ++++++------- compiler/InterpreterLoops.ml | 20 +-- compiler/InterpreterLoopsCore.ml | 4 +- compiler/InterpreterLoopsFixedPoint.ml | 56 +++---- compiler/InterpreterLoopsJoinCtxs.ml | 46 +++--- compiler/InterpreterLoopsMatchCtxs.ml | 162 ++++++++++----------- compiler/InterpreterPaths.ml | 48 +++--- compiler/InterpreterProjectors.ml | 56 +++---- compiler/InterpreterStatements.ml | 106 +++++++------- compiler/InterpreterUtils.ml | 18 +-- compiler/Invariants.ml | 178 +++++++++++------------ compiler/PrePasses.ml | 8 +- compiler/Print.ml | 12 +- compiler/PrintPure.ml | 38 ++--- compiler/PureMicroPasses.ml | 22 +-- compiler/PureTypeCheck.ml | 78 +++++----- compiler/PureUtils.ml | 34 ++--- compiler/RegionsHierarchy.ml | 12 +- compiler/Substitute.ml | 16 +- compiler/SymbolicToPure.ml | 148 +++++++++---------- compiler/SynthesizeSymbolic.ml | 16 +- compiler/Translate.ml | 4 +- compiler/TypesAnalysis.ml | 2 +- compiler/ValuesUtils.ml | 16 +- 36 files changed, 929 insertions(+), 928 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 5d5f53a4..8faaf62b 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -51,7 +51,7 @@ let compute_norm_trait_types_from_preds (meta : Meta.meta option) (* Sanity check: the type constraint can't make use of regions - Remark that it would be enough to only visit the field [ty] of the trait type constraint, but for safety we visit all the fields *) - sanity_check_opt_meta (trait_type_constraint_no_regions c) meta; + sanity_check_opt_meta __FILE__ __LINE__ (trait_type_constraint_no_regions c) meta; let { trait_ref; type_name; ty } : trait_type_constraint = c in let trait_ty = TTraitType (trait_ref, type_name) in let trait_ty_ref = get_ref trait_ty in @@ -239,7 +239,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = match trait_ref.trait_id with | TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ } -> - cassert_opt_meta + cassert_opt_meta __FILE__ __LINE__ (ref_generics = empty_generic_args) ctx.meta "Higher order trait types are not supported yet"; log#ldebug @@ -281,7 +281,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* We can't project *) - sanity_check_opt_meta + sanity_check_opt_meta __FILE__ __LINE__ (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta; TTraitType (trait_ref, type_name) @@ -351,7 +351,7 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) match impl with | None -> (* This is actually a local clause *) - sanity_check_opt_meta + sanity_check_opt_meta __FILE__ __LINE__ (trait_instance_id_is_local_clause inst_id) ctx.meta; (ParentClause (inst_id, decl_id, clause_id), None) @@ -384,7 +384,7 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) match impl with | None -> (* This is actually a local clause *) - sanity_check_opt_meta + sanity_check_opt_meta __FILE__ __LINE__ (trait_instance_id_is_local_clause inst_id) ctx.meta; (ItemClause (inst_id, decl_id, item_name, clause_id), None) @@ -426,10 +426,10 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) - cassert_opt_meta + cassert_opt_meta __FILE__ __LINE__ (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta "Trait instance id is not a local sub-clause"; - cassert_opt_meta + cassert_opt_meta __FILE__ __LINE__ (trait_ref.generics = empty_generic_args) ctx.meta "TODO: error message"; (trait_ref.trait_id, None) @@ -480,7 +480,7 @@ and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : trait_ref) : (lazy ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); - cassert_opt_meta + cassert_opt_meta __FILE__ __LINE__ (generics = empty_generic_args) ctx.meta "TODO: error message"; trait_ref diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index c2d6999a..edda4260 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -298,7 +298,7 @@ let env_lookup_var (meta : Meta.meta) (env : env) (vid : VarId.id) : | EBinding (BVar var, v) :: env' -> if var.index = vid then (var, v) else lookup env' | (EBinding (BDummy _, _) | EAbs _) :: env' -> lookup env' - | EFrame :: _ -> craise meta "End of frame" + | EFrame :: _ -> craise __FILE__ __LINE__ meta "End of frame" in lookup env @@ -349,12 +349,12 @@ let env_update_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) *) let rec update env = match env with - | [] -> craise meta "Unexpected" + | [] -> craise __FILE__ __LINE__ meta "Unexpected" | EBinding ((BVar b as var), v) :: env' -> if b.index = vid then EBinding (var, nv) :: env' else EBinding (var, v) :: update env' | ((EBinding (BDummy _, _) | EAbs _) as ee) :: env' -> ee :: update env' - | EFrame :: _ -> craise meta "End of frame" + | EFrame :: _ -> craise __FILE__ __LINE__ meta "End of frame" in update env @@ -377,7 +377,7 @@ let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) *) let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - cassert + cassert __FILE__ __LINE__ (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty) meta "The pushed variables and their values do not have the same type"; let bv = var_to_binder var in @@ -399,7 +399,7 @@ let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) (* We can unfortunately not use Print because it depends on Contexts... *) show_var var ^ " -> " ^ show_typed_value value) vars))); - cassert + cassert __FILE__ __LINE__ (List.for_all (fun (var, (value : typed_value)) -> TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) @@ -432,7 +432,7 @@ let ctx_remove_dummy_var meta (ctx : eval_ctx) (vid : DummyVarId.id) : eval_ctx * typed_value = let rec remove_var (env : env) : env * typed_value = match env with - | [] -> craise meta "Could not lookup a dummy variable" + | [] -> craise __FILE__ __LINE__ meta "Could not lookup a dummy variable" | EBinding (BDummy vid', v) :: env when vid' = vid -> (env, v) | ee :: env -> let env, v = remove_var env in @@ -446,7 +446,7 @@ let ctx_lookup_dummy_var (meta : Meta.meta) (ctx : eval_ctx) (vid : DummyVarId.id) : typed_value = let rec lookup_var (env : env) : typed_value = match env with - | [] -> craise meta "Could not lookup a dummy variable" + | [] -> craise __FILE__ __LINE__ meta "Could not lookup a dummy variable" | EBinding (BDummy vid', v) :: _env when vid' = vid -> v | _ :: env -> lookup_var env in @@ -495,7 +495,7 @@ let env_remove_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) : env * abs option = let rec remove (env : env) : env * abs option = match env with - | [] -> craise meta "Unreachable" + | [] -> craise __FILE__ __LINE__ meta "Unreachable" | EFrame :: _ -> (env, None) | EBinding (bv, v) :: env -> let env, abs_opt = remove env in @@ -521,7 +521,7 @@ let env_subst_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) (nabs : abs) : env * abs option = let rec update (env : env) : env * abs option = match env with - | [] -> craise meta "Unreachable" + | [] -> craise __FILE__ __LINE__ meta "Unreachable" | EFrame :: _ -> (* We're done *) (env, None) | EBinding (bv, v) :: env -> let env, opt_abs = update env in diff --git a/compiler/Errors.ml b/compiler/Errors.ml index 68073ef7..bfdf5796 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -13,43 +13,43 @@ exception CFailure of string let error_list : (Meta.meta option * string) list ref = ref [] -let push_error (meta : Meta.meta option) (msg : string) = - error_list := (meta, msg) :: !error_list +let push_error (file : string) (line : int) (meta : Meta.meta option) (msg : string) = + error_list := (meta, msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line) :: !error_list -let save_error ?(b : bool = true) (meta : Meta.meta option) (msg : string) = - push_error meta msg; +let save_error (file : string) (line : int) ?(b : bool = true) (meta : Meta.meta option) (msg : string) = + push_error file line meta msg; match meta with | Some m -> if !Config.fail_hard && b then - raise (Failure (format_error_message m msg)) + raise (Failure (format_error_message m (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line))) | None -> if !Config.fail_hard && b then raise (Failure msg) -let craise_opt_meta (meta : Meta.meta option) (msg : string) = +let craise_opt_meta (file : string) (line : int) (meta : Meta.meta option) (msg : string) = match meta with | Some m -> - if !Config.fail_hard then raise (Failure (format_error_message m msg)) + if !Config.fail_hard then raise (Failure (format_error_message m (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line))) else - let () = push_error (Some m) msg in + let () = push_error file line (Some m) msg in raise (CFailure msg) | None -> - if !Config.fail_hard then raise (Failure msg) + if !Config.fail_hard then raise (Failure (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line)) else - let () = push_error None msg in + let () = push_error file line None msg in raise (CFailure msg) -let craise (meta : Meta.meta) (msg : string) = craise_opt_meta (Some meta) msg +let craise (file : string) (line : int) (meta : Meta.meta) (msg : string) = craise_opt_meta file line (Some meta) msg -let cassert_opt_meta (b : bool) (meta : Meta.meta option) (msg : string) = - if not b then craise_opt_meta meta msg +let cassert_opt_meta (file : string) (line : int) (b : bool) (meta : Meta.meta option) (msg : string) = + if not b then craise_opt_meta file line meta msg -let cassert (b : bool) (meta : Meta.meta) (msg : string) = - cassert_opt_meta b (Some meta) msg +let cassert (file : string) (line : int) (b : bool) (meta : Meta.meta) (msg : string) = + cassert_opt_meta file line b (Some meta) msg -let sanity_check b meta = cassert b meta "Internal error, please file an issue" +let sanity_check (file : string) (line : int) b meta = cassert file line b meta "Internal error, please file an issue" -let sanity_check_opt_meta b meta = - cassert_opt_meta b meta "Internal error, please file an issue" +let sanity_check_opt_meta (file : string) (line : int) b meta = + cassert_opt_meta file line b meta "Internal error, please file an issue" -let internal_error meta = craise meta "Internal error, please report an issue" +let internal_error (file : string) (line : int) meta = craise file line meta "Internal error, please report an issue" let exec_raise = craise let exec_assert = cassert diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 72cd91e5..4fb0e3c8 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -60,7 +60,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (* Add the decreases proof for Lean only *) match !Config.backend with | Coq | FStar -> ctx - | HOL4 -> craise def.meta "Unexpected" + | HOL4 -> craise __FILE__ __LINE__ def.meta "Unexpected" | Lean -> ctx_add_decreases_proof def ctx else ctx in @@ -128,10 +128,10 @@ let extract_adt_g_value (meta : Meta.meta) | TAdt (TTuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) - cassert + cassert __FILE__ __LINE__ (List.length generics.types = List.length field_values) meta "Only fully applied tuple constructors are currently supported"; - cassert + cassert __FILE__ __LINE__ (generics.const_generics = [] && generics.trait_refs = []) meta "Only fully applied tuple constructors are currently supported"; extract_as_tuple () @@ -187,7 +187,7 @@ let extract_adt_g_value (meta : Meta.meta) in if use_parentheses then F.pp_print_string fmt ")"; ctx - | _ -> craise meta "Inconsistent typed value" + | _ -> craise __FILE__ __LINE__ meta "Inconsistent typed value" (* Extract globals in the same way as variables *) let extract_global (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) @@ -281,7 +281,7 @@ let lets_require_wrap_in_do (meta : Meta.meta) (* HOL4 is similar to HOL4, but we add a sanity check *) let wrap_in_do = List.exists (fun (m, _, _) -> m) lets in if wrap_in_do then - sanity_check (List.for_all (fun (m, _, _) -> m) lets) meta; + sanity_check __FILE__ __LINE__ (List.for_all (fun (m, _, _) -> m) lets) meta; wrap_in_do | FStar | Coq -> false @@ -320,7 +320,7 @@ let rec extract_texpression (meta : Meta.meta) (ctx : extraction_ctx) | StructUpdate supd -> extract_StructUpdate meta ctx fmt inside e.ty supd | Loop _ -> (* The loop nodes should have been eliminated in {!PureMicroPasses} *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" (* Extract an application *or* a top-level qualif (function extraction has * to handle top-level qualifiers, so it seemed more natural to merge the @@ -454,7 +454,7 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) if not method_id.is_provided then ( (* Required method *) - sanity_check (lp_id = None) trait_decl.meta; + sanity_check __FILE__ __LINE__ (lp_id = None) trait_decl.meta; extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref; let fun_name = @@ -485,7 +485,7 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) F.pp_print_string fmt fun_name); (* Sanity check: HOL4 doesn't support const generics *) - sanity_check (generics.const_generics = [] || !backend <> HOL4) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = [] || !backend <> HOL4) meta; (* Print the generics. We might need to filter some of the type arguments, if the type @@ -505,9 +505,9 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) | Error (types, err) -> extract_generic_args meta ctx fmt TypeDeclId.Set.empty { generics with types }; - (* if !Config.fail_hard then craise meta err + (* if !Config.fail_hard then craise __FILE__ __LINE__ meta err else *) - save_error (Some meta) err; + save_error __FILE__ __LINE__ (Some meta) err; F.pp_print_string fmt "(\"ERROR: ill-formed builtin: invalid number of filtering \ arguments\")"); @@ -522,7 +522,7 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (* Return *) if inside then F.pp_print_string fmt ")" | (Unop _ | Binop _), _ -> - craise meta + craise __FILE__ __LINE__ meta ("Unreachable:\n" ^ "Function: " ^ show_fun_or_op_id fid ^ ",\nNumber of arguments: " ^ string_of_int (List.length args) @@ -644,7 +644,7 @@ and extract_field_projector (meta : Meta.meta) (ctx : extraction_ctx) extract_App meta ctx fmt inside (mk_app meta original_app arg) args | [] -> (* No argument: shouldn't happen *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (xl : typed_pattern list) (e : texpression) : unit = @@ -653,7 +653,7 @@ and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (* Open parentheses *) if inside then F.pp_print_string fmt "("; (* Print the lambda - note that there should always be at least one variable *) - sanity_check (xl <> []) meta; + sanity_check __FILE__ __LINE__ (xl <> []) meta; F.pp_print_string fmt "fun"; let with_type = !backend = Coq in let ctx = @@ -726,7 +726,7 @@ and extract_lets (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) let arrow = match !backend with | Coq | HOL4 -> "<-" - | FStar | Lean -> craise meta "impossible" + | FStar | Lean -> craise __FILE__ __LINE__ meta "impossible" in F.pp_print_string fmt arrow; F.pp_print_space fmt (); @@ -959,7 +959,7 @@ and extract_StructUpdate (meta : Meta.meta) (ctx : extraction_ctx) unit = (* We can't update a subset of the fields in Coq (i.e., we can do [{| x:= 3; y := 4 |}], but there is no syntax for [{| s with x := 3 |}]) *) - sanity_check (!backend <> Coq || supd.init = None) meta; + sanity_check __FILE__ __LINE__ (!backend <> Coq || supd.init = None) meta; (* In the case of HOL4, records with no fields are not supported and are thus extracted to unit. We need to check that by looking up the definition *) let extract_as_unit = @@ -1099,7 +1099,7 @@ and extract_StructUpdate (meta : Meta.meta) (ctx : extraction_ctx) F.pp_print_string fmt "]"; if need_paren then F.pp_print_string fmt ")"; F.pp_close_box fmt () - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" (** A small utility to print the parameters of a function signature. @@ -1202,7 +1202,7 @@ let assert_backend_supports_decreases_clauses (meta : Meta.meta) = match !backend with | FStar | Lean -> () | _ -> - craise meta + craise __FILE__ __LINE__ meta "Decreases clauses are only supported for the Lean and F* backends" (** Extract a decreases clause function template body. @@ -1223,7 +1223,7 @@ let assert_backend_supports_decreases_clauses (meta : Meta.meta) = *) let extract_template_fstar_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - cassert (!backend = FStar) def.meta + cassert __FILE__ __LINE__ (!backend = FStar) def.meta "The generation of template decrease clauses is only supported for the F* \ backend"; @@ -1292,7 +1292,7 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) *) let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - cassert (!backend = Lean) def.meta + cassert __FILE__ __LINE__ (!backend = Lean) def.meta "The generation of template termination and decreasing clauses is only \ supported for the Lean backend"; (* @@ -1419,7 +1419,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - sanity_check (not def.is_global_decl_body) def.meta; + sanity_check __FILE__ __LINE__ (not def.is_global_decl_body) def.meta; (* Retrieve the function name *) let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in (* Add a break before *) @@ -1672,7 +1672,7 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = (* Retrieve the definition name *) let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in - cassert + cassert __FILE__ __LINE__ (def.signature.generics.const_generics = []) def.meta "Constant generics are not supported yet when generating code for HOL4"; @@ -1721,7 +1721,7 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - sanity_check (not def.is_global_decl_body) def.meta; + sanity_check __FILE__ __LINE__ (not def.is_global_decl_body) def.meta; (* We treat HOL4 opaque functions in a specific manner *) if !backend = HOL4 && Option.is_none def.body then extract_fun_decl_hol4_opaque ctx fmt def @@ -1872,8 +1872,8 @@ let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : global_decl) (body : fun_decl) (interface : bool) : unit = let meta = body.meta in - cassert body.is_global_decl_body body.meta "TODO: Error message"; - cassert (body.signature.inputs = []) body.meta "TODO: Error message"; + cassert __FILE__ __LINE__ body.is_global_decl_body body.meta "TODO: Error message"; + cassert __FILE__ __LINE__ (body.signature.inputs = []) body.meta "TODO: Error message"; (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; @@ -2225,7 +2225,7 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) in (* For now we do not support overriding provided methods *) - cassert + cassert __FILE__ __LINE__ (trait_impl.provided_methods = []) trait_impl.meta "Overriding provided methods is not supported yet"; (* Everything is taken care of by {!extract_trait_decl_register_names} *but* diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 99167ae4..eb37a726 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -253,8 +253,8 @@ let empty_names_map : names_map = } (** Small helper to report name collision *) -let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) - (name : string) : unit = +let report_name_collision (id_to_string : id -> string) + ((id1, meta) : id * Meta.meta option) (id2 : id) (name : string) : unit = let id1 = "\n- " ^ id_to_string id1 in let id2 = "\n- " ^ id_to_string id2 in let err = @@ -263,9 +263,10 @@ let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) ^ "\nYou may want to rename some of your definitions, or report an issue." in (* If we fail hard on errors, raise an exception *) - save_error None err + save_error meta err -let names_map_get_id_from_name (name : string) (nm : names_map) : id option = +let names_map_get_id_from_name (name : string) (nm : names_map) : + (id * meta option) option = StringMap.find_opt name nm.name_to_id let names_map_check_collision (id_to_string : id -> string) (id : id) @@ -296,7 +297,7 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) ^ ":\nThe chosen name is already in the names set: " ^ name in (* If we fail hard on errors, raise an exception *) - save_error None err); + save_error __FILE__ __LINE__ None err); (* Insert *) names_map_add_unchecked id name nm @@ -443,7 +444,7 @@ let names_maps_get (meta : Meta.meta option) (id_to_string : id -> string) "Could not find: " ^ id_to_string id ^ "\nNames map:\n" ^ map_to_string m in - save_error meta err; + save_error __FILE__ __LINE__ meta err; "(%%%ERROR: unknown identifier\": " ^ id_to_string id ^ "\"%%%)") else let m = nm.names_map.id_to_name in @@ -454,7 +455,7 @@ let names_maps_get (meta : Meta.meta option) (id_to_string : id -> string) "Could not find: " ^ id_to_string id ^ "\nNames map:\n" ^ map_to_string m in - save_error meta err; + save_error __FILE__ __LINE__ meta err; "(ERROR: \"" ^ id_to_string id ^ "\")" type names_map_init = { @@ -681,7 +682,7 @@ let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) let ctx_get_type (meta : Meta.meta option) (id : type_id) (ctx : extraction_ctx) : string = - sanity_check_opt_meta (id <> TTuple) meta; + sanity_check_opt_meta __FILE__ __LINE__ (id <> TTuple) meta; ctx_get meta (TypeId id) ctx let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) @@ -1201,7 +1202,7 @@ let type_decl_kind_to_qualif (meta : Meta.meta) (kind : decl_kind) (* This is for traits *) Some "Record" | _ -> - craise meta + craise __FILE__ __LINE__ meta ("Unexpected: (" ^ show_decl_kind kind ^ ", " ^ Print.option_to_string show_type_decl_kind type_kind ^ ")")) @@ -1262,13 +1263,13 @@ let type_keyword (meta : Meta.meta) = match !backend with | FStar -> "Type0" | Coq | Lean -> "Type" - | HOL4 -> craise meta "Unexpected" + | HOL4 -> craise __FILE__ __LINE__ meta "Unexpected" (** Helper *) let name_last_elem_as_ident (meta : Meta.meta) (n : llbc_name) : string = match Collections.List.last n with | PeIdent (s, _) -> s - | PeImpl _ -> craise meta "Unexpected" + | PeImpl _ -> craise __FILE__ __LINE__ meta "Unexpected" (** Helper @@ -1284,7 +1285,7 @@ let ctx_prepare_name (meta : Meta.meta) (ctx : extraction_ctx) | (PeIdent (crate, _) as id) :: name -> if crate = ctx.crate.name then name else id :: name | _ -> - craise meta + craise __FILE__ __LINE__ meta ("Unexpected name shape: " ^ TranslateCore.name_to_string ctx.trans_ctx name) @@ -1597,7 +1598,7 @@ let ctx_compute_termination_measure_name (meta : Meta.meta) match !Config.backend with | FStar -> "_decreases" | Lean -> "_terminates" - | Coq | HOL4 -> craise meta "Unexpected" + | Coq | HOL4 -> craise __FILE__ __LINE__ meta "Unexpected" in (* Concatenate *) fname ^ lp_suffix ^ suffix @@ -1625,7 +1626,7 @@ let ctx_compute_decreases_proof_name (meta : Meta.meta) (ctx : extraction_ctx) let suffix = match !Config.backend with | Lean -> "_decreases" - | FStar | Coq | HOL4 -> craise meta "Unexpected" + | FStar | Coq | HOL4 -> craise __FILE__ __LINE__ meta "Unexpected" in (* Concatenate *) fname ^ lp_suffix ^ suffix @@ -1656,7 +1657,7 @@ let ctx_compute_var_basename (meta : Meta.meta) (ctx : extraction_ctx) let cl = to_snake_case name in let cl = String.split_on_char '_' cl in let cl = List.filter (fun s -> String.length s > 0) cl in - sanity_check (List.length cl > 0) meta; + sanity_check __FILE__ __LINE__ (List.length cl > 0) meta; let cl = List.map (fun s -> s.[0]) cl in StringUtils.string_of_chars cl in @@ -1936,7 +1937,7 @@ let ctx_compute_fun_name (def : fun_decl) (ctx : extraction_ctx) : string = let ctx_add_fun_decl (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = (* Sanity check: the function should not be a global body - those are handled * separately *) - sanity_check (not def.is_global_decl_body) def.meta; + sanity_check __FILE__ __LINE__ (not def.is_global_decl_body) def.meta; (* Lookup the LLBC def to compute the region group information *) let def_id = def.def_id in (* Add the function name *) diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index e9d6116f..0573512d 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -73,7 +73,7 @@ let pattern_to_extract_name (meta : Meta.meta option) (name : pattern) : let id = Collections.List.last id in match id with | PIdent (_, _) -> super#visit_PImpl () (EComp [ id ]) - | PImpl _ -> craise_opt_meta meta "Unreachable") + | PImpl _ -> craise_opt_meta __FILE__ __LINE__ meta "Unreachable") | _ -> super#visit_PImpl () ty method! visit_EPrimAdt _ adt g = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index d785e299..f737f73b 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -29,7 +29,7 @@ let extract_literal (meta : Meta.meta) (fmt : F.formatter) (inside : bool) | HOL4 -> F.pp_print_string fmt ("int_to_" ^ int_name sv.int_ty); F.pp_print_space fmt () - | _ -> craise meta "Unreachable"); + | _ -> craise __FILE__ __LINE__ meta "Unreachable"); (* We need to add parentheses if the value is negative *) if sv.value >= Z.of_int 0 then F.pp_print_string fmt (Z.to_string sv.value) @@ -42,7 +42,7 @@ let extract_literal (meta : Meta.meta) (fmt : F.formatter) (inside : bool) let iname = String.lowercase_ascii (int_name sv.int_ty) in F.pp_print_string fmt ("#" ^ iname) | HOL4 -> () - | _ -> craise meta "Unreachable"); + | _ -> craise __FILE__ __LINE__ meta "Unreachable"); if print_brackets then F.pp_print_string fmt ")") | VBool b -> let b = @@ -129,7 +129,7 @@ let extract_unop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) match !backend with | Coq | FStar -> "scalar_cast" | Lean -> "Scalar.cast" - | HOL4 -> craise meta "Unreachable" + | HOL4 -> craise __FILE__ __LINE__ meta "Unreachable" in let src = if !backend <> Lean then Some (integer_type_to_string src) @@ -142,20 +142,20 @@ let extract_unop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) match !backend with | Coq | FStar -> "scalar_cast_bool" | Lean -> "Scalar.cast_bool" - | HOL4 -> craise meta "Unreachable" + | HOL4 -> craise __FILE__ __LINE__ meta "Unreachable" in let tgt = integer_type_to_string tgt in (cast_str, None, Some tgt) | TInteger _, TBool -> (* This is not allowed by rustc: the way of doing it in Rust is: [x != 0] *) - craise meta "Unexpected cast: integer to bool" + craise __FILE__ __LINE__ meta "Unexpected cast: integer to bool" | TBool, TBool -> (* There shouldn't be any cast here. Note that if one writes [b as bool] in Rust (where [b] is a boolean), it gets compiled to [b] (i.e., no cast is introduced). *) - craise meta "Unexpected cast: bool to bool" - | _ -> craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unexpected cast: bool to bool" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in (* Print the name of the function *) F.pp_print_string fmt cast_str; @@ -289,7 +289,7 @@ let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt ("val [" ^ String.concat ", " names ^ "] = DefineDiv ‘") else ( - sanity_check_opt_meta (List.length names = 1) None; + sanity_check_opt_meta __FILE__ __LINE__ (List.length names = 1) None; let name = List.hd names in F.pp_print_string fmt ("val " ^ name ^ " = Define ‘")); F.pp_print_cut fmt () @@ -498,14 +498,14 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) | HOL4 -> let { types; const_generics; trait_refs } = generics in (* Const generics are not supported in HOL4 *) - cassert (const_generics = []) meta + cassert __FILE__ __LINE__ (const_generics = []) meta "Constant generics are not supported yet when generating code \ for HOL4"; let print_tys = match type_id with | TAdtId id -> not (TypeDeclId.Set.mem id no_params_tys) | TAssumed _ -> true - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in if types <> [] && print_tys then ( let print_paren = List.length types > 1 in @@ -534,7 +534,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) extract_rec false ret_ty; if inside then F.pp_print_string fmt ")" | TTraitType (trait_ref, type_name) -> ( - if !parameterize_trait_types then craise meta "Unimplemented" + if !parameterize_trait_types then craise __FILE__ __LINE__ meta "Unimplemented" else let type_name = ctx_get_trait_type meta trait_ref.trait_decl_ref.trait_decl_id @@ -552,7 +552,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) *) match trait_ref.trait_id with | Self -> - cassert + cassert __FILE__ __LINE__ (trait_ref.generics = empty_generic_args) meta "TODO: Error message"; extract_trait_instance_id_with_dot meta ctx fmt no_params_tys false @@ -560,7 +560,7 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt type_name | _ -> (* HOL4 doesn't have 1st class types *) - cassert (!backend <> HOL4) meta + cassert __FILE__ __LINE__ (!backend <> HOL4) meta "Trait types are not supported yet when generating code for HOL4"; extract_trait_ref meta ctx fmt no_params_tys false trait_ref; F.pp_print_string fmt ("." ^ add_brackets type_name)) @@ -615,7 +615,7 @@ and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) (extract_ty meta ctx fmt no_params_tys true) types); if const_generics <> [] then ( - cassert (!backend <> HOL4) meta + cassert __FILE__ __LINE__ (!backend <> HOL4) meta "Constant generics are not supported yet when generating code for HOL4"; F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) @@ -671,7 +671,7 @@ and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) | Self -> (* This has a specific treatment depending on the item we're extracting (associated type, etc.). We should have caught this elsewhere. *) - save_error (Some meta) "Unexpected occurrence of `Self`"; + save_error __FILE__ __LINE__ (Some meta) "Unexpected occurrence of `Self`"; F.pp_print_string fmt "ERROR(\"Unexpected Self\")" | TraitImpl id -> let name = ctx_get_trait_impl meta id ctx in @@ -695,7 +695,7 @@ and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) extract_trait_ref meta ctx fmt no_params_tys inside trait_ref | UnknownTrait _ -> (* This is an error case *) - craise meta "Unexpected" + craise __FILE__ __LINE__ meta "Unexpected" (** Compute the names for all the top-level identifiers used in a type definition (type name, variant names, field names, etc. but not type @@ -772,7 +772,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : in (field_names, cons_name) | Some info -> - craise def.meta + craise __FILE__ __LINE__ def.meta ("Invalid builtin information: " ^ show_builtin_type_info info) in (* Add the fields *) @@ -818,7 +818,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : (fun variant_id (variant : variant) -> (variant_id, StringMap.find variant.variant_name variant_map)) variants - | _ -> craise def.meta "Invalid builtin information" + | _ -> craise __FILE__ __LINE__ def.meta "Invalid builtin information" in List.fold_left (fun ctx (vid, vname) -> @@ -887,7 +887,7 @@ let extract_type_decl_variant (meta : Meta.meta) (ctx : extraction_ctx) List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields in (* Sanity check: HOL4 doesn't support const generics *) - sanity_check (cg_params = [] || !backend <> HOL4) meta; + sanity_check __FILE__ __LINE__ (cg_params = [] || !backend <> HOL4) meta; (* Print the final type *) if !backend <> HOL4 then ( F.pp_print_space fmt (); @@ -1089,7 +1089,7 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) else ( (* We extract for Coq or Lean, and we have a recursive record, or a record in a group of mutually recursive types: we extract it as an inductive type *) - cassert + cassert __FILE__ __LINE__ (is_rec && (!backend = Coq || !backend = Lean)) def.meta "Constant generics are not supported yet when generating code for HOL4"; @@ -1196,7 +1196,7 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* HOL4 doesn't support const generics *) - cassert + cassert __FILE__ __LINE__ (cg_params = [] || !backend <> HOL4) meta "Constant generics are not supported yet when generating code for HOL4"; let left_bracket (implicit : bool) = @@ -1346,7 +1346,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) (extract_body : bool) : unit = (* Sanity check *) - sanity_check (extract_body || !backend <> HOL4) def.meta; + sanity_check __FILE__ __LINE__ (extract_body || !backend <> HOL4) def.meta; let is_tuple_struct = TypesUtils.type_decl_from_decl_id_is_tuple_struct ctx.trans_ctx.type_ctx.type_infos def.def_id @@ -1418,7 +1418,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) | None -> F.pp_print_string fmt def_name); (* HOL4 doesn't support const generics, and type definitions in HOL4 don't support trait clauses *) - cassert + cassert __FILE__ __LINE__ ((cg_params = [] && trait_clauses = []) || !backend <> HOL4) def.meta "Constant generics and type definitions with trait clauses are not \ @@ -1465,7 +1465,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) | Enum variants -> extract_type_decl_enum_body ctx_body fmt type_decl_group def def_name type_params cg_params variants - | Opaque -> craise def.meta "Unreachable"); + | Opaque -> craise __FILE__ __LINE__ def.meta "Unreachable"); (* Add the definition end delimiter *) if !backend = HOL4 && decl_is_not_last_from_group kind then ( F.pp_print_space fmt (); @@ -1491,12 +1491,12 @@ let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (* Retrieve the definition name *) let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Generic parameters are unsupported *) - cassert + cassert __FILE__ __LINE__ (def.generics.const_generics = []) def.meta "Constant generics are not supported yet when generating code for HOL4"; (* Trait clauses on type definitions are unsupported *) - cassert + cassert __FILE__ __LINE__ (def.generics.trait_clauses = []) def.meta "Types with trait clauses are not supported yet when generating code for \ @@ -1523,7 +1523,7 @@ let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) (* Retrieve the definition name *) let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Sanity check *) - sanity_check (def.generics = empty_generic_params) def.meta; + sanity_check __FILE__ __LINE__ (def.generics = empty_generic_params) def.meta; (* Generate the declaration *) F.pp_print_space fmt (); F.pp_print_string fmt ("Type " ^ def_name ^ " = “: unit”"); @@ -1599,7 +1599,7 @@ let extract_coq_arguments_instruction (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = - sanity_check (!backend = Coq) decl.meta; + sanity_check __FILE__ __LINE__ (!backend = Coq) decl.meta; (* Generating the [Arguments] instructions is useful only if there are parameters *) let num_params = List.length decl.generics.types @@ -1647,7 +1647,7 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_type_decl_record_field_projectors (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = - sanity_check (!backend = Coq) decl.meta; + sanity_check __FILE__ __LINE__ (!backend = Coq) decl.meta; match decl.kind with | Opaque | Enum _ -> () | Struct fields -> diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index f85f9d1e..df2a010d 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -145,7 +145,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) end in (* Sanity check: global bodies don't contain stateful calls *) - sanity_check ((not f.is_global_decl_body) || not !stateful) f.meta; + sanity_check __FILE__ __LINE__ ((not f.is_global_decl_body) || not !stateful) f.meta; let builtin_info = get_builtin_info f in let has_builtin_info = builtin_info <> None in group_has_builtin_info := !group_has_builtin_info || has_builtin_info; @@ -167,11 +167,11 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) (* We need to know if the declaration group contains a global - note that * groups containing globals contain exactly one declaration *) let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in - cassert + cassert __FILE__ __LINE__ ((not is_global_decl_body) || List.length d = 1) (List.hd d).meta "This global definition is in a group of mutually recursive definitions"; - cassert + cassert __FILE__ __LINE__ ((not !group_has_builtin_info) || List.length d = 1) (List.hd d).meta "This builtin function belongs to a group of mutually recursive \ diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 453ad088..ea1d5633 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -85,7 +85,7 @@ let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) List.map (fun (v : const_generic_var) -> CgVar v.index) const_generics in (* Annoying that we have to generate this substitution here *) - let r_subst _ = craise meta "Unexpected region" in + let r_subst _ = craise __FILE__ __LINE__ meta "Unexpected region" in let ty_subst = Substitute.make_type_subst_from_vars sg.generics.types types in @@ -123,7 +123,7 @@ let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) trait_instance_id = match TraitClauseId.Map.find_opt clause_id tr_map with | Some tr -> tr - | None -> craise meta "Local trait clause not found" + | None -> craise __FILE__ __LINE__ meta "Local trait clause not found" in let mk_subst tr_map = let tr_subst = mk_tr_subst tr_map in @@ -215,7 +215,7 @@ let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : in (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) let call_id = fresh_fun_call_id () in - sanity_check (call_id = FunCallId.zero) fdef.meta; + sanity_check __FILE__ __LINE__ (call_id = FunCallId.zero) fdef.meta; let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : eval_ctx * typed_avalue list = (* Project over the values - we use *loan* projectors, as explained above *) @@ -337,7 +337,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) let region_can_end rid = RegionGroupId.Set.mem rid parent_and_current_rgs in - sanity_check (region_can_end back_id) fdef.meta; + sanity_check __FILE__ __LINE__ (region_can_end back_id) fdef.meta; let ctx = create_push_abstractions_from_abs_region_groups (fun rg_id -> SynthRet rg_id) @@ -424,7 +424,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) | Loop (loop_id', rg_id', LoopSynthInput) -> (* We only allow to end the loop synth input abs for the region group [rg_id] *) - sanity_check + sanity_check __FILE__ __LINE__ (if Option.is_some loop_id then loop_id = Some loop_id' else true) fdef.meta; @@ -435,7 +435,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) else abs | Loop (loop_id', _, LoopCall) -> (* We can end all the loop call abstractions *) - sanity_check (loop_id = Some loop_id') fdef.meta; + sanity_check __FILE__ __LINE__ (loop_id = Some loop_id') fdef.meta; { abs with can_end = true } | SynthInput rg_id' -> if rg_id' = back_id && end_fun_synth_input then @@ -538,7 +538,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) match res with | Return -> None | LoopReturn loop_id -> Some loop_id - | _ -> craise fdef.meta "Unreachable" + | _ -> craise __FILE__ __LINE__ fdef.meta "Unreachable" in let is_regular_return = true in let inside_loop = Option.is_some loop_id in @@ -564,7 +564,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) match res with | EndEnterLoop _ -> false | EndContinue _ -> true - | _ -> craise fdef.meta "Unreachable" + | _ -> craise __FILE__ __LINE__ fdef.meta "Unreachable" in (* Forward translation *) let fwd_e = @@ -605,7 +605,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) * the executions can lead to a panic *) if synthesize then Some SA.Panic else None | Unit | Break _ | Continue _ -> - craise fdef.meta + craise __FILE__ __LINE__ fdef.meta ("evaluate_function_symbolic failed on: " ^ name_to_string ()) in @@ -636,8 +636,8 @@ module Test = struct fdef.name)); (* Sanity check - *) - sanity_check (fdef.signature.generics = empty_generic_params) fdef.meta; - sanity_check (body.arg_count = 0) fdef.meta; + sanity_check __FILE__ __LINE__ (fdef.signature.generics = empty_generic_params) fdef.meta; + sanity_check __FILE__ __LINE__ (body.arg_count = 0) fdef.meta; (* Create the evaluation context *) let ctx = initialize_eval_ctx fdef.meta decls_ctx [] [] [] in @@ -654,7 +654,7 @@ module Test = struct let pop_return_value = true in pop_frame config fdef.meta pop_return_value (fun _ _ -> None) ctx | _ -> - craise fdef.meta + craise __FILE__ __LINE__ fdef.meta ("Unit test failed (concrete execution) on: " ^ Print.Types.name_to_string (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 2ccf2d5d..cc34020a 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -43,7 +43,7 @@ let end_borrow_get_borrow (meta : Meta.meta) in let set_replaced_bc (abs_id : AbstractionId.id option) (bc : g_borrow_content) = - sanity_check (Option.is_none !replaced_bc) meta; + sanity_check __FILE__ __LINE__ (Option.is_none !replaced_bc) meta; replaced_bc := Some (abs_id, bc) in (* Raise an exception if: @@ -182,7 +182,7 @@ let end_borrow_get_borrow (meta : Meta.meta) * Also note that, as we are moving the borrowed value inside the * abstraction (and not really giving the value back to the context) * we do not insert {!AEndedMutBorrow} but rather {!ABottom} *) - craise meta "Unimplemented" + craise __FILE__ __LINE__ meta "Unimplemented" (* ABottom *)) else (* Update the outer borrows before diving into the child avalue *) @@ -225,8 +225,8 @@ let end_borrow_get_borrow (meta : Meta.meta) method! visit_abs outer abs = (* Update the outer abs *) let outer_abs, outer_borrows = outer in - sanity_check (Option.is_none outer_abs) meta; - sanity_check (Option.is_none outer_borrows) meta; + sanity_check __FILE__ __LINE__ (Option.is_none outer_abs) meta; + sanity_check __FILE__ __LINE__ (Option.is_none outer_borrows) meta; let outer = (Some abs.abs_id, None) in super#visit_abs outer abs end @@ -249,10 +249,10 @@ let end_borrow_get_borrow (meta : Meta.meta) let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv : typed_value) (ctx : eval_ctx) : eval_ctx = (* Sanity check *) - exec_assert + exec_assert __FILE__ __LINE__ (not (loans_in_value nv)) meta "Can not end a borrow because the value to give back contains bottom"; - exec_assert + exec_assert __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions nv)) meta "Can not end a borrow because the value to give back contains bottom"; (* Debug *) @@ -266,7 +266,7 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - sanity_check (not !replaced) meta; + sanity_check __FILE__ __LINE__ (not !replaced) meta; replaced := true in (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) @@ -308,7 +308,7 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) ("give_back_value: improper type:\n- expected: " ^ ty_to_string ctx ty ^ "\n- received: " ^ ty_to_string ctx nv.ty); - craise meta "Value given back doesn't have the proper type"); + craise __FILE__ __LINE__ meta "Value given back doesn't have the proper type"); (* Replace *) set_replaced (); nv.value) @@ -353,7 +353,7 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) ABorrow (AEndedIgnoredMutBorrow { given_back; child; given_back_meta }) - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" else (* Continue exploring *) ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) @@ -368,7 +368,7 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (* Preparing a bit *) let regions, ancestors_regions = match opt_abs with - | None -> craise meta "Unreachable" + | None -> craise __FILE__ __LINE__ meta "Unreachable" | Some abs -> (abs.regions, abs.ancestors_regions) in (* Rk.: there is a small issue with the types of the aloan values. @@ -434,7 +434,7 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (* We remember in which abstraction we are before diving - * this is necessary for projecting values: we need to know * over which regions to project *) - sanity_check (Option.is_none opt_abs) meta; + sanity_check __FILE__ __LINE__ (Option.is_none opt_abs) meta; super#visit_EAbs (Some abs) abs end in @@ -442,7 +442,7 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - cassert !replaced meta "Only one loan should have been given back"; + cassert __FILE__ __LINE__ !replaced meta "Only one loan should have been given back"; (* Apply the reborrows *) apply_registered_reborrows ctx @@ -451,7 +451,7 @@ let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) - sanity_check (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) meta; + sanity_check __FILE__ __LINE__ (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) meta; (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in (* Substitution function, to replace the borrow projectors over symbolic values *) @@ -473,7 +473,7 @@ let give_back_symbolic_value (_config : config) (meta : Meta.meta) type [T]! We thus *mustn't* introduce a projector here. *) (* AProjBorrows (nsv, sv.sv_ty) *) - internal_error meta + internal_error __FILE__ __LINE__ meta in AProjLoans (sv, (mv, child_proj) :: local_given_back) in @@ -498,7 +498,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - cassert (not !replaced) meta "Only one loan should have been updated"; + cassert __FILE__ __LINE__ (not !replaced) meta "Only one loan should have been updated"; replaced := true in let obj = @@ -541,7 +541,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) ("give_back_avalue_to_same_abstraction: improper type:\n\ - expected: " ^ ty_to_string ctx ty ^ "\n- received: " ^ ty_to_string ctx nv.ty); - craise meta "Value given back doesn't have the proper type"); + craise __FILE__ __LINE__ meta "Value given back doesn't have the proper type"); (* This is the loan we are looking for: apply the projection to * the value we give back and replaced this mutable loan with * an ended loan *) @@ -567,7 +567,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) * we don't register the fact that we inserted the value somewhere * (i.e., we don't call {!set_replaced}) *) (* Sanity check *) - sanity_check (nv.ty = ty) meta; + sanity_check __FILE__ __LINE__ (nv.ty = ty) meta; ALoan (AEndedIgnoredMutLoan { given_back = nv; child; given_back_meta = nsv })) @@ -583,7 +583,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - cassert !replaced meta "Only one loan should be given back"; + cassert __FILE__ __LINE__ !replaced meta "Only one loan should be given back"; (* Return *) ctx @@ -601,7 +601,7 @@ let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - cassert (not !replaced) meta "Only one loan should be updated"; + cassert __FILE__ __LINE__ (not !replaced) meta "Only one loan should be updated"; replaced := true in let obj = @@ -666,7 +666,7 @@ let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - cassert !replaced meta "Exactly one loan should be given back"; + cassert __FILE__ __LINE__ !replaced meta "Exactly one loan should be given back"; (* Return *) ctx @@ -680,7 +680,7 @@ let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (* Keep track of changes *) let r = ref false in let set_ref () = - sanity_check (not !r) meta; + sanity_check __FILE__ __LINE__ (not !r) meta; r := true in @@ -710,7 +710,7 @@ let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) let env = obj#visit_env () ctx.env in (* Check that we reborrowed once *) - sanity_check !r meta; + sanity_check __FILE__ __LINE__ !r meta; { ctx with env } (** Convert an {!type:avalue} to a {!type:value}. @@ -770,24 +770,24 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) match bc with | Concrete (VMutBorrow (l', tv)) -> (* Sanity check *) - sanity_check (l' = l) meta; - sanity_check (not (loans_in_value tv)) meta; + sanity_check __FILE__ __LINE__ (l' = l) meta; + sanity_check __FILE__ __LINE__ (not (loans_in_value tv)) meta; (* Check that the corresponding loan is somewhere - purely a sanity check *) - sanity_check (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; + sanity_check __FILE__ __LINE__ (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; (* Update the context *) give_back_value config meta l tv ctx | Concrete (VSharedBorrow l' | VReservedMutBorrow l') -> (* Sanity check *) - sanity_check (l' = l) meta; + sanity_check __FILE__ __LINE__ (l' = l) meta; (* Check that the borrow is somewhere - purely a sanity check *) - sanity_check (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; + sanity_check __FILE__ __LINE__ (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; (* Update the context *) give_back_shared config meta l ctx | Abstract (AMutBorrow (l', av)) -> (* Sanity check *) - sanity_check (l' = l) meta; + sanity_check __FILE__ __LINE__ (l' = l) meta; (* Check that the corresponding loan is somewhere - purely a sanity check *) - sanity_check (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; + sanity_check __FILE__ __LINE__ (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; (* Convert the avalue to a (fresh symbolic) value. Rem.: we shouldn't do this here. We should do this in a function @@ -800,20 +800,20 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) ctx | Abstract (ASharedBorrow l') -> (* Sanity check *) - sanity_check (l' = l) meta; + sanity_check __FILE__ __LINE__ (l' = l) meta; (* Check that the borrow is somewhere - purely a sanity check *) - sanity_check (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; + sanity_check __FILE__ __LINE__ (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; (* Update the context *) give_back_shared config meta l ctx | Abstract (AProjSharedBorrow asb) -> (* Sanity check *) - sanity_check (borrow_in_asb l asb) meta; + sanity_check __FILE__ __LINE__ (borrow_in_asb l asb) meta; (* Update the context *) give_back_shared config meta l ctx | Abstract ( AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedSharedBorrow ) -> - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowId.id) (ctx0 : eval_ctx) : cm_fun = @@ -829,7 +829,7 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); - craise meta "Borrow not eliminated" + craise __FILE__ __LINE__ meta "Borrow not eliminated" in match lookup_loan_opt meta ek_all l ctx with | None -> () (* Ok *) @@ -841,7 +841,7 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); - craise meta "Loan not eliminated" + craise __FILE__ __LINE__ meta "Loan not eliminated" in unit_to_cm_fun check_disappeared @@ -937,7 +937,7 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) log#ldebug (lazy "End borrow: borrow not found"); (* It is possible that we can't find a borrow in symbolic mode (ending * an abstraction may end several borrows at once *) - sanity_check (config.mode = SymbolicMode) meta; + sanity_check __FILE__ __LINE__ (config.mode = SymbolicMode) meta; (* Do a sanity check and continue *) cf_check cf ctx (* We found a borrow and replaced it with [Bottom]: give it back (i.e., update @@ -946,7 +946,7 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (* Sanity check: the borrowed value shouldn't contain loans *) (match bc with | Concrete (VMutBorrow (_, bv)) -> - sanity_check (Option.is_none (get_first_loan_in_value bv)) meta + sanity_check __FILE__ __LINE__ (Option.is_none (get_first_loan_in_value bv)) meta | _ -> ()); (* Give back the value *) let ctx = give_back config meta l bc ctx in @@ -1002,7 +1002,7 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (* Check that we can end the abstraction *) if abs.can_end then () else - craise meta + craise __FILE__ __LINE__ meta ("Can't end abstraction " ^ AbstractionId.to_string abs.abs_id ^ " as it is set as non-endable"); @@ -1172,7 +1172,7 @@ and end_abstraction_borrows (config : config) (meta : Meta.meta) method! visit_aproj env sproj = (match sproj with - | AProjLoans _ -> craise meta "Unexpected" + | AProjLoans _ -> craise __FILE__ __LINE__ meta "Unexpected" | AProjBorrows (sv, proj_ty) -> raise (FoundAProjBorrows (sv, proj_ty)) | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj env sproj @@ -1181,7 +1181,7 @@ and end_abstraction_borrows (config : config) (meta : Meta.meta) method! visit_borrow_content _ bc = match bc with | VSharedBorrow _ | VMutBorrow (_, _) -> raise (FoundBorrowContent bc) - | VReservedMutBorrow _ -> craise meta "Unreachable" + | VReservedMutBorrow _ -> craise __FILE__ __LINE__ meta "Unreachable" end in (* Lookup the abstraction *) @@ -1241,7 +1241,7 @@ and end_abstraction_borrows (config : config) (meta : Meta.meta) ctx | AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedSharedBorrow -> - craise meta "Unexpected" + craise __FILE__ __LINE__ meta "Unexpected" in (* Reexplore *) end_abstraction_borrows config meta chain abs_id cf ctx @@ -1276,7 +1276,7 @@ and end_abstraction_borrows (config : config) (meta : Meta.meta) match end_borrow_get_borrow meta (Some abs_id) allow_inner_loans bid ctx with - | Error _ -> craise meta "Unreachable" + | Error _ -> craise __FILE__ __LINE__ meta "Unreachable" | Ok (ctx, _) -> (* Give back *) give_back_shared config meta bid ctx) @@ -1286,12 +1286,12 @@ and end_abstraction_borrows (config : config) (meta : Meta.meta) match end_borrow_get_borrow meta (Some abs_id) allow_inner_loans bid ctx with - | Error _ -> craise meta "Unreachable" + | Error _ -> craise __FILE__ __LINE__ meta "Unreachable" | Ok (ctx, _) -> (* Give the value back - note that the mut borrow was below a * shared borrow: the value is thus unchanged *) give_back_value config meta bid v ctx) - | VReservedMutBorrow _ -> craise meta "Unreachable" + | VReservedMutBorrow _ -> craise __FILE__ __LINE__ meta "Unreachable" in (* Reexplore *) end_abstraction_borrows config meta chain abs_id cf ctx @@ -1430,7 +1430,7 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) * replace it with... Maybe we should introduce an ABottomProj? *) let ctx = update_aproj_borrows meta abs_id sv AIgnoredProjBorrows ctx in (* Sanity check: no other occurrence of an intersecting projector of borrows *) - sanity_check + sanity_check __FILE__ __LINE__ (Option.is_none (lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx)) @@ -1509,22 +1509,22 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) in match lookup_loan meta ek l ctx with | _, Concrete (VMutLoan _) -> - craise meta "Expected a shared loan, found a mut loan" + craise __FILE__ __LINE__ meta "Expected a shared loan, found a mut loan" | _, Concrete (VSharedLoan (bids, sv)) -> (* Check that there is only one borrow id (l) and update the loan *) - cassert + cassert __FILE__ __LINE__ (BorrowId.Set.mem l bids && BorrowId.Set.cardinal bids = 1) meta "There should only be one borrow id"; (* We need to check that there aren't any loans in the value: we should have gotten rid of those already, but it is better to do a sanity check. *) - sanity_check (not (loans_in_value sv)) meta; + sanity_check __FILE__ __LINE__ (not (loans_in_value sv)) meta; (* Check there isn't {!Bottom} (this is actually an invariant *) - cassert + cassert __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions sv)) meta "There shouldn't be a bottom"; (* Check there aren't reserved borrows *) - cassert + cassert __FILE__ __LINE__ (not (reserved_in_value sv)) meta "There shouldn't be reserved borrows"; (* Update the loan content *) @@ -1534,7 +1534,7 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) | _, Abstract _ -> (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) - craise meta + craise __FILE__ __LINE__ meta "Can't promote a shared loan to a mutable loan if the loan is inside \ an abstraction" @@ -1555,13 +1555,13 @@ let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) let ctx = match lookup_borrow meta ek l ctx with | Concrete (VSharedBorrow _ | VMutBorrow (_, _)) -> - craise meta "Expected a reserved mutable borrow" + craise __FILE__ __LINE__ meta "Expected a reserved mutable borrow" | Concrete (VReservedMutBorrow _) -> (* Update it *) update_borrow meta ek l (VMutBorrow (l, borrowed_value)) ctx | Abstract _ -> (* This can't happen for sure *) - craise meta + craise __FILE__ __LINE__ meta "Can't promote a shared borrow to a mutable borrow if the borrow is \ inside an abstraction" in @@ -1577,7 +1577,7 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } in match lookup_loan meta ek l ctx with - | _, Concrete (VMutLoan _) -> craise meta "Unreachable" + | _, Concrete (VMutLoan _) -> craise __FILE__ __LINE__ meta "Unreachable" | _, Concrete (VSharedLoan (bids, sv)) -> ( (* If there are loans inside the value, end them. Note that there can't be reserved borrows inside the value. @@ -1601,9 +1601,9 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) (lazy ("activate_reserved_mut_borrow: resulting value:\n" ^ typed_value_to_string ~meta:(Some meta) ctx sv)); - sanity_check (not (loans_in_value sv)) meta; - sanity_check (not (bottom_in_value ctx.ended_regions sv)) meta; - sanity_check (not (reserved_in_value sv)) meta; + sanity_check __FILE__ __LINE__ (not (loans_in_value sv)) meta; + sanity_check __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions sv)) meta; + sanity_check __FILE__ __LINE__ (not (reserved_in_value sv)) meta; (* End the borrows which borrow from the value, at the exception of the borrow we want to promote *) let bids = BorrowId.Set.remove l bids in @@ -1625,7 +1625,7 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) | _, Abstract _ -> (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) - craise meta + craise __FILE__ __LINE__ meta "Can't activate a reserved mutable borrow referencing a loan inside\n\ \ an abstraction" @@ -1642,7 +1642,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) ignore the children altogether. Instead, we explore them and make sure we don't register values while doing so. *) - let push_fail _ = craise meta "Unreachable" in + let push_fail _ = craise __FILE__ __LINE__ meta "Unreachable" in (* Function to explore an avalue and destructure it *) let rec list_avalues (allow_borrows : bool) (push : typed_avalue -> unit) (av : typed_avalue) : unit = @@ -1657,7 +1657,7 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) match lc with | ASharedLoan (bids, sv, child_av) -> (* We don't support nested borrows for now *) - cassert + cassert __FILE__ __LINE__ (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; (* Destructure the shared value *) @@ -1686,10 +1686,10 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) push { value; ty } | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) - cassert + cassert __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; - sanity_check (opt_bid = None) meta; + sanity_check __FILE__ __LINE__ (opt_bid = None) meta; (* Simply explore the child *) list_avalues false push_fail child_av | AEndedMutLoan @@ -1699,14 +1699,14 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) { child = child_av; given_back = _; given_back_meta = _ } | AIgnoredSharedLoan child_av -> (* We don't support nested borrows for now *) - cassert + cassert __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; (* Simply explore the child *) list_avalues false push_fail child_av) | ABorrow bc -> ( (* Sanity check - rem.: may be redundant with [push_fail] *) - sanity_check allow_borrows meta; + sanity_check __FILE__ __LINE__ allow_borrows meta; (* Explore the borrow content *) match bc with | AMutBorrow (bid, child_av) -> @@ -1721,23 +1721,23 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) push av | AIgnoredMutBorrow (opt_bid, child_av) -> (* We don't support nested borrows for now *) - cassert + cassert __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; - sanity_check (opt_bid = None) meta; + sanity_check __FILE__ __LINE__ (opt_bid = None) meta; (* Just explore the child *) list_avalues false push_fail child_av | AEndedIgnoredMutBorrow { child = child_av; given_back = _; given_back_meta = _ } -> (* We don't support nested borrows for now *) - cassert + cassert __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; (* Just explore the child *) list_avalues false push_fail child_av | AProjSharedBorrow asb -> (* We don't support nested borrows *) - cassert (asb = []) meta "Nested borrows are not supported yet"; + cassert __FILE__ __LINE__ (asb = []) meta "Nested borrows are not supported yet"; (* Nothing specific to do *) () | AEndedMutBorrow _ | AEndedSharedBorrow -> @@ -1745,11 +1745,11 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) be in the context anymore (if we end *one* borrow in an abstraction, we have to end them all and remove the abstraction from the context) *) - craise meta "Unreachable") + craise __FILE__ __LINE__ meta "Unreachable") | ASymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) - sanity_check (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta + sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta and list_values (v : typed_value) : typed_avalue list * typed_value = let ty = v.ty in match v.value with @@ -1761,20 +1761,20 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) let avl = List.concat avll in let adt = { adt with field_values } in (avl, { v with value = VAdt adt }) - | VBottom -> craise meta "Unreachable" + | VBottom -> craise __FILE__ __LINE__ meta "Unreachable" | VBorrow _ -> (* We don't support nested borrows for now *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | VLoan lc -> ( match lc with | VSharedLoan (bids, sv) -> let avl, sv = list_values sv in if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) - cassert (ty_no_regions ty) meta + cassert __FILE__ __LINE__ (ty_no_regions ty) meta "Nested borrows are not supported yet"; let av : typed_avalue = - sanity_check + sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv.value)) meta; (* We introduce fresh ids for the symbolic values *) @@ -1799,11 +1799,11 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) let avl = List.append [ av ] avl in (avl, sv)) else (avl, { v with value = VLoan (VSharedLoan (bids, sv)) }) - | VMutLoan _ -> craise meta "Unreachable") + | VMutLoan _ -> craise __FILE__ __LINE__ meta "Unreachable") | VSymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) - sanity_check (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta; + sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta; ([], v) in @@ -1903,14 +1903,14 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (avl, { v with value = VAdt adt }) | VBorrow bc -> ( let _, ref_ty, kind = ty_as_ref ty in - cassert (ty_no_regions ref_ty) meta + cassert __FILE__ __LINE__ (ty_no_regions ref_ty) meta "Nested borrows are not supported yet"; (* Sanity check *) - sanity_check allow_borrows meta; + sanity_check __FILE__ __LINE__ allow_borrows meta; (* Convert the borrow content *) match bc with | VSharedBorrow bid -> - cassert (ty_no_regions ref_ty) meta + cassert __FILE__ __LINE__ (ty_no_regions ref_ty) meta "Nested borrows are not supported yet"; let ty = TRef (RFVar r_id, ref_ty, kind) in let value = ABorrow (ASharedBorrow bid) in @@ -1918,7 +1918,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) | VMutBorrow (bid, bv) -> let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) - cassert + cassert __FILE__ __LINE__ (not (value_has_borrows ctx bv.value)) meta "Nested borrows are not supported yet"; (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) @@ -1933,18 +1933,18 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (av :: avl, value) | VReservedMutBorrow _ -> (* This borrow should have been activated *) - craise meta "Unexpected") + craise __FILE__ __LINE__ meta "Unexpected") | VLoan lc -> ( match lc with | VSharedLoan (bids, sv) -> let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) - cassert + cassert __FILE__ __LINE__ (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - cassert (ty_no_regions ty) meta + cassert __FILE__ __LINE__ (ty_no_regions ty) meta "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RShared in let ignored = mk_aignored meta ty in @@ -1963,7 +1963,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) | VMutLoan bid -> (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - cassert (ty_no_regions ty) meta + cassert __FILE__ __LINE__ (ty_no_regions ty) meta "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RMut in let ignored = mk_aignored meta ty in @@ -1973,7 +1973,7 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) | VSymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - cassert + cassert __FILE__ __LINE__ (not (value_has_borrows ctx v.value)) meta "Nested borrows are not supported yet"; (* Return nothing *) @@ -2029,26 +2029,26 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) in let push_loans ids (lc : g_loan_content_with_ty) : unit = - sanity_check (BorrowId.Set.disjoint !loans ids) meta; + sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint !loans ids) meta; loans := BorrowId.Set.union !loans ids; BorrowId.Set.iter (fun id -> - sanity_check (not (BorrowId.Map.mem id !loan_to_content)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem id !loan_to_content)) meta; loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans) ids in let push_loan id (lc : g_loan_content_with_ty) : unit = - sanity_check (not (BorrowId.Set.mem id !loans)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Set.mem id !loans)) meta; loans := BorrowId.Set.add id !loans; - sanity_check (not (BorrowId.Map.mem id !loan_to_content)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem id !loan_to_content)) meta; loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans in let push_borrow id (bc : g_borrow_content_with_ty) : unit = - sanity_check (not (BorrowId.Set.mem id !borrows)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Set.mem id !borrows)) meta; borrows := BorrowId.Set.add id !borrows; - sanity_check (not (BorrowId.Map.mem id !borrow_to_content)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem id !borrow_to_content)) meta; borrow_to_content := BorrowId.Map.add id bc !borrow_to_content; borrows_loans := BorrowId id :: !borrows_loans in @@ -2071,23 +2071,23 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) let ty = match Option.get env with | Concrete ty -> ty - | Abstract _ -> craise meta "Unreachable" + | Abstract _ -> craise __FILE__ __LINE__ meta "Unreachable" in (match lc with | VSharedLoan (bids, _) -> push_loans bids (Concrete (ty, lc)) - | VMutLoan _ -> craise meta "Unreachable"); + | VMutLoan _ -> craise __FILE__ __LINE__ meta "Unreachable"); (* Continue *) super#visit_loan_content env lc method! visit_borrow_content _ _ = (* Can happen if we explore shared values which contain borrows - i.e., if we have nested borrows (we forbid this for now) *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" method! visit_aloan_content env lc = let ty = match Option.get env with - | Concrete _ -> craise meta "Unreachable" + | Concrete _ -> craise __FILE__ __LINE__ meta "Unreachable" | Abstract ty -> ty in (* Register the loans *) @@ -2097,14 +2097,14 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) | AEndedMutLoan _ | AEndedSharedLoan _ | AIgnoredMutLoan _ | AEndedIgnoredMutLoan _ | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) - craise meta "Unreachable"); + craise __FILE__ __LINE__ meta "Unreachable"); (* Continue *) super#visit_aloan_content env lc method! visit_aborrow_content env bc = let ty = match Option.get env with - | Concrete _ -> craise meta "Unreachable" + | Concrete _ -> craise __FILE__ __LINE__ meta "Unreachable" | Abstract ty -> ty in (* Explore the borrow content *) @@ -2118,18 +2118,18 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) | AsbProjReborrows _ -> (* Can only happen if the symbolic value (potentially) contains borrows - i.e., we have nested borrows *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in List.iter register asb | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedMutBorrow _ | AEndedSharedBorrow -> (* The abstraction has been destructured, so those shouldn't appear *) - craise meta "Unreachable"); + craise __FILE__ __LINE__ meta "Unreachable"); super#visit_aborrow_content env bc method! visit_symbolic_value _ sv = (* Sanity check: no borrows *) - sanity_check (not (symbolic_value_has_borrows ctx sv)) meta + sanity_check __FILE__ __LINE__ (not (symbolic_value_has_borrows ctx sv)) meta end in @@ -2209,10 +2209,10 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (* Check that the abstractions are destructured *) if !Config.sanity_checks then ( let destructure_shared_values = true in - sanity_check + sanity_check __FILE__ __LINE__ (abs_is_destructured meta destructure_shared_values ctx abs0) meta; - sanity_check + sanity_check __FILE__ __LINE__ (abs_is_destructured meta destructure_shared_values ctx abs1) meta); @@ -2240,8 +2240,8 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) if merge_funs = None then - (sanity_check (BorrowId.Set.disjoint borrows0 borrows1) meta; - sanity_check (BorrowId.Set.disjoint loans0 loans1)) + (sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint borrows0 borrows1) meta; + sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint loans0 loans1)) meta; (* Merge. @@ -2283,7 +2283,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) in let filter_bids (bids : BorrowId.Set.t) : BorrowId.Set.t = let bids = BorrowId.Set.diff bids intersect in - sanity_check (not (BorrowId.Set.is_empty bids)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Set.is_empty bids)) meta; bids in let filter_bid (bid : BorrowId.id) : BorrowId.id option = @@ -2311,11 +2311,11 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (Option.get merge_funs).merge_ashared_borrows id ty0 ty1 | AProjSharedBorrow _, AProjSharedBorrow _ -> (* Unreachable because requires nested borrows *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | _ -> (* Unreachable because those cases are ignored (ended/ignored borrows) or inconsistent *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in let merge_g_borrow_contents (bc0 : g_borrow_content_with_ty) @@ -2323,12 +2323,12 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) match (bc0, bc1) with | Concrete _, Concrete _ -> (* This can happen only in case of nested borrows *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Abstract (ty0, bc0), Abstract (ty1, bc1) -> merge_aborrow_contents ty0 bc0 ty1 bc1 | Concrete _, Abstract _ | Abstract _, Concrete _ -> (* TODO: is it really unreachable? *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in let merge_aloan_contents (ty0 : rty) (lc0 : aloan_content) (ty1 : rty) @@ -2346,7 +2346,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (* Check that the sets of ids are the same - if it is not the case, it means we actually need to merge more than 2 avalues: we ignore this case for now *) - sanity_check (BorrowId.Set.equal ids0 ids1) meta; + sanity_check __FILE__ __LINE__ (BorrowId.Set.equal ids0 ids1) meta; let ids = ids0 in if BorrowId.Set.is_empty ids then ( (* If the set of ids is empty, we can eliminate this shared loan. @@ -2358,10 +2358,10 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) to preserve (in practice it works because we destructure the shared values in the abstractions, and forbid nested borrows). *) - sanity_check (not (value_has_loans_or_borrows ctx sv0.value)) meta; - sanity_check (not (value_has_loans_or_borrows ctx sv0.value)) meta; - sanity_check (is_aignored child0.value) meta; - sanity_check (is_aignored child1.value) meta; + sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv0.value)) meta; + sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv0.value)) meta; + sanity_check __FILE__ __LINE__ (is_aignored child0.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child1.value) meta; None) else ( (* Register the loan ids *) @@ -2373,7 +2373,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) | _ -> (* Unreachable because those cases are ignored (ended/ignored borrows) or inconsistent *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in (* Note that because we may filter ids from a set of id, this function has @@ -2384,12 +2384,12 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) match (lc0, lc1) with | Concrete _, Concrete _ -> (* This can not happen: the values should have been destructured *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Abstract (ty0, lc0), Abstract (ty1, lc1) -> merge_aloan_contents ty0 lc0 ty1 lc1 | Concrete _, Abstract _ | Abstract _, Concrete _ -> (* TODO: is it really unreachable? *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in (* Note that we first explore the borrows/loans of [abs1], because we @@ -2430,12 +2430,12 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) a concrete borrow can only happen inside a shared loan *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Abstract (ty, bc) -> { value = ABorrow bc; ty }) | Some bc0, Some bc1 -> - sanity_check (merge_funs <> None) meta; + sanity_check __FILE__ __LINE__ (merge_funs <> None) meta; merge_g_borrow_contents bc0 bc1 - | None, None -> craise meta "Unreachable" + | None, None -> craise __FILE__ __LINE__ meta "Unreachable" in push_avalue av) | LoanId bid -> @@ -2468,16 +2468,16 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) | Concrete _ -> (* This shouldn't happen because the avalues should have been destructured. *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Abstract (ty, lc) -> ( match lc with | ASharedLoan (bids, sv, child) -> let bids = filter_bids bids in - sanity_check + sanity_check __FILE__ __LINE__ (not (BorrowId.Set.is_empty bids)) meta; - sanity_check (is_aignored child.value) meta; - sanity_check + sanity_check __FILE__ __LINE__ (is_aignored child.value) meta; + sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv.value)) meta; let lc = ASharedLoan (bids, sv, child) in @@ -2490,11 +2490,11 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) | AIgnoredMutLoan _ | AEndedIgnoredMutLoan _ | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) - craise meta "Unreachable")) + craise __FILE__ __LINE__ meta "Unreachable")) | Some lc0, Some lc1 -> - sanity_check (merge_funs <> None) meta; + sanity_check __FILE__ __LINE__ (merge_funs <> None) meta; merge_g_loan_contents lc0 lc1 - | None, None -> craise meta "Unreachable" + | None, None -> craise __FILE__ __LINE__ meta "Unreachable" in push_opt_avalue av)) borrows_loans; @@ -2512,7 +2512,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) match av.value with | ABorrow _ -> true | ALoan _ -> false - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in let aborrows, aloans = List.partition is_borrow avalues in List.append aborrows aloans @@ -2547,7 +2547,7 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) in (* Sanity check *) - sanity_check (abs_is_destructured meta true ctx abs) meta; + sanity_check __FILE__ __LINE__ (abs_is_destructured meta true ctx abs) meta; (* Return *) abs diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 02ceffb4..fd656063 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -75,7 +75,7 @@ let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = let add_borrow_or_abs_id_to_chain (meta : Meta.meta) (msg : string) (id : borrow_or_abs_id) (ids : borrow_or_abs_ids) : borrow_or_abs_ids = if List.mem id ids then - craise meta + craise __FILE__ __LINE__ meta (msg ^ "detected a loop in the chain of ids: " ^ borrow_or_abs_ids_chain_to_string (id :: ids)) else id :: ids @@ -100,17 +100,17 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) = let compare = compare_rtys meta default combine compare_regions in (* Sanity check - TODO: don't do this at every recursive call *) - sanity_check (ty_is_rty ty1 && ty_is_rty ty2) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty ty1 && ty_is_rty ty2) meta; (* Normalize the associated types *) match (ty1, ty2) with | TLiteral lit1, TLiteral lit2 -> - sanity_check (lit1 = lit2) meta; + sanity_check __FILE__ __LINE__ (lit1 = lit2) meta; default | TAdt (id1, generics1), TAdt (id2, generics2) -> - sanity_check (id1 = id2) meta; + sanity_check __FILE__ __LINE__ (id1 = id2) meta; (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) - sanity_check (generics1.const_generics = generics2.const_generics) meta; + sanity_check __FILE__ __LINE__ (generics1.const_generics = generics2.const_generics) meta; (* We also ignore the trait refs *) @@ -144,7 +144,7 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) combine params_b tys_b | TRef (r1, ty1, kind1), TRef (r2, ty2, kind2) -> (* Sanity check *) - sanity_check (kind1 = kind2) meta; + sanity_check __FILE__ __LINE__ (kind1 = kind2) meta; (* Explanation for the case where we check if projections intersect: * the projections intersect if the borrows intersect or their contents * intersect. *) @@ -152,19 +152,19 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) let tys_b = compare ty1 ty2 in combine regions_b tys_b | TVar id1, TVar id2 -> - sanity_check (id1 = id2) meta; + sanity_check __FILE__ __LINE__ (id1 = id2) meta; default | TTraitType _, TTraitType _ -> (* The types should have been normalized. If after normalization we get trait types, we can consider them as variables *) - sanity_check (ty1 = ty2) meta; + sanity_check __FILE__ __LINE__ (ty1 = ty2) meta; default | _ -> log#lerror (lazy ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ show_ty ty1 ^ "\n- ty2: " ^ show_ty ty2)); - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" (** Check if two different projections intersect. This is necessary when giving a symbolic value to an abstraction: we need to check that @@ -269,7 +269,7 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) super#visit_aloan_content env lc method! visit_EBinding env bv v = - sanity_check (Option.is_none !abs_or_var) meta; + sanity_check __FILE__ __LINE__ (Option.is_none !abs_or_var) meta; abs_or_var := Some (match bv with @@ -279,7 +279,7 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) abs_or_var := None method! visit_EAbs env abs = - sanity_check (Option.is_none !abs_or_var) meta; + sanity_check __FILE__ __LINE__ (Option.is_none !abs_or_var) meta; if ek.enter_abs then ( abs_or_var := Some (AbsId abs.abs_id); super#visit_EAbs env abs; @@ -294,7 +294,7 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) with FoundGLoanContent lc -> ( match !abs_or_var with | Some abs_or_var -> Some (abs_or_var, lc) - | None -> craise meta "Inconsistent state") + | None -> craise __FILE__ __LINE__ meta "Inconsistent state") (** Lookup a loan content. @@ -304,7 +304,7 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : abs_or_var_id * g_loan_content = match lookup_loan_opt meta ek l ctx with - | None -> craise meta "Unreachable" + | None -> craise __FILE__ __LINE__ meta "Unreachable" | Some res -> res (** Update a loan content. @@ -320,7 +320,7 @@ let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) * returning we check that we updated at least once. *) let r = ref false in let update () : loan_content = - sanity_check (not !r) meta; + sanity_check __FILE__ __LINE__ (not !r) meta; r := true; nlc in @@ -367,7 +367,7 @@ let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one loan *) - sanity_check !r meta; + sanity_check __FILE__ __LINE__ !r meta; ctx (** Update a abstraction loan content. @@ -383,7 +383,7 @@ let update_aloan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) * returning we check that we updated at least once. *) let r = ref false in let update () : aloan_content = - sanity_check (not !r) meta; + sanity_check __FILE__ __LINE__ (not !r) meta; r := true; nlc in @@ -416,7 +416,7 @@ let update_aloan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one loan *) - sanity_check !r meta; + sanity_check __FILE__ __LINE__ !r meta; ctx (** Lookup a borrow content from a borrow id. *) @@ -485,7 +485,7 @@ let lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) let lookup_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : g_borrow_content = match lookup_borrow_opt ek l ctx with - | None -> craise meta "Unreachable" + | None -> craise __FILE__ __LINE__ meta "Unreachable" | Some lc -> lc (** Update a borrow content. @@ -501,7 +501,7 @@ let update_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) * returning we check that we updated at least once. *) let r = ref false in let update () : borrow_content = - sanity_check (not !r) meta; + sanity_check __FILE__ __LINE__ (not !r) meta; r := true; nbc in @@ -542,7 +542,7 @@ let update_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one borrow *) - sanity_check !r meta; + sanity_check __FILE__ __LINE__ !r meta; ctx (** Update an abstraction borrow content. @@ -558,7 +558,7 @@ let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) * returning we check that we updated at least once. *) let r = ref false in let update () : avalue = - sanity_check (not !r) meta; + sanity_check __FILE__ __LINE__ (not !r) meta; r := true; nv in @@ -589,7 +589,7 @@ let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) let ctx = obj#visit_eval_ctx () ctx in (* Check that we updated at least one borrow *) - cassert !r meta "No borrow was updated"; + cassert __FILE__ __LINE__ !r meta "No borrow was updated"; ctx (** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) @@ -708,13 +708,13 @@ let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) let set_non_shared ((id, ty) : AbstractionId.id * rty) : unit = match !found with | None -> found := Some (NonSharedProj (id, ty)) - | Some _ -> craise meta "Unreachable" + | Some _ -> craise __FILE__ __LINE__ meta "Unreachable" in let add_shared (x : AbstractionId.id * rty) : unit = match !found with | None -> found := Some (SharedProjs [ x ]) | Some (SharedProjs pl) -> found := Some (SharedProjs (x :: pl)) - | Some (NonSharedProj _) -> craise meta "Unreachable" + | Some (NonSharedProj _) -> craise __FILE__ __LINE__ meta "Unreachable" in let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = if @@ -734,7 +734,7 @@ let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) method! visit_abstract_shared_borrow abs asb = (* Sanity check *) (match !found with - | Some (NonSharedProj _) -> craise meta "Unreachable" + | Some (NonSharedProj _) -> craise __FILE__ __LINE__ meta "Unreachable" | _ -> ()); (* Explore *) if lookup_shared then @@ -782,7 +782,7 @@ let lookup_intersecting_aproj_borrows_not_shared_opt (meta : Meta.meta) with | None -> None | Some (NonSharedProj (abs_id, rty)) -> Some (abs_id, rty) - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" (** Similar to {!lookup_intersecting_aproj_borrows_opt}, but updates the values. @@ -800,12 +800,12 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) let add_shared () = match !shared with | None -> shared := Some true - | Some b -> sanity_check b meta + | Some b -> sanity_check __FILE__ __LINE__ b meta in let set_non_shared () = match !shared with | None -> shared := Some false - | Some _ -> craise meta "Found unexpected intersecting proj_borrows" + | Some _ -> craise __FILE__ __LINE__ meta "Found unexpected intersecting proj_borrows" in let check_proj_borrows is_shared abs sv' proj_ty = if @@ -825,7 +825,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) method! visit_abstract_shared_borrows abs asb = (* Sanity check *) - (match !shared with Some b -> sanity_check b meta | _ -> ()); + (match !shared with Some b -> sanity_check __FILE__ __LINE__ b meta | _ -> ()); (* Explore *) if can_update_shared then let abs = Option.get abs in @@ -857,7 +857,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Check that we updated the context at least once *) - cassert (Option.is_some !shared) meta "Context was not updated at least once"; + cassert __FILE__ __LINE__ (Option.is_some !shared) meta "Context was not updated at least once"; (* Return *) ctx @@ -873,7 +873,7 @@ let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = false in - let update_shared _ _ = craise meta "Unexpected" in + let update_shared _ _ = craise __FILE__ __LINE__ meta "Unexpected" in let updated = ref false in let update_non_shared _ _ = (* We can update more than one borrow! *) @@ -886,7 +886,7 @@ let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) update_non_shared regions sv ctx in (* Check that we updated at least once *) - sanity_check !updated meta; + sanity_check __FILE__ __LINE__ !updated meta; (* Return *) ctx @@ -901,7 +901,7 @@ let remove_intersecting_aproj_borrows_shared (meta : Meta.meta) (* Small helpers *) let can_update_shared = true in let update_shared _ _ = [] in - let update_non_shared _ _ = craise meta "Unexpected" in + let update_non_shared _ _ = craise __FILE__ __LINE__ meta "Unexpected" in (* Update *) update_intersecting_aproj_borrows meta can_update_shared update_shared update_non_shared regions sv ctx @@ -942,7 +942,7 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (subst : abs -> (msymbolic_value * aproj) list -> aproj) (ctx : eval_ctx) : eval_ctx = (* *) - sanity_check (ty_is_rty proj_ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty proj_ty) meta; (* Small helpers for sanity checks *) let updated = ref false in let update abs local_given_back : aproj = @@ -964,7 +964,7 @@ let update_intersecting_aproj_loans (meta : Meta.meta) | AProjLoans (sv', given_back) -> let abs = Option.get abs in if same_symbolic_id sv sv' then ( - sanity_check (sv.sv_ty = sv'.sv_ty) meta; + sanity_check __FILE__ __LINE__ (sv.sv_ty = sv'.sv_ty) meta; if projections_intersect meta proj_ty proj_regions sv'.sv_ty abs.regions @@ -976,7 +976,7 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Check that we updated the context at least once *) - sanity_check !updated meta; + sanity_check __FILE__ __LINE__ !updated meta; (* Return *) ctx @@ -996,7 +996,7 @@ let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) let found = ref None in let set_found x = (* There is at most one projector which corresponds to the description *) - sanity_check (Option.is_none !found) meta; + sanity_check __FILE__ __LINE__ (Option.is_none !found) meta; found := Some x in (* The visitor *) @@ -1014,9 +1014,9 @@ let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) super#visit_aproj abs sproj | AProjLoans (sv', given_back) -> let abs = Option.get abs in - sanity_check (abs.abs_id = abs_id) meta; + sanity_check __FILE__ __LINE__ (abs.abs_id = abs_id) meta; if sv'.sv_id = sv.sv_id then ( - sanity_check (sv' = sv) meta; + sanity_check __FILE__ __LINE__ (sv' = sv) meta; set_found given_back) else ()); super#visit_aproj abs sproj @@ -1041,7 +1041,7 @@ let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) let found = ref false in let update () = (* We update at most once *) - sanity_check (not !found) meta; + sanity_check __FILE__ __LINE__ (not !found) meta; found := true; nproj in @@ -1060,9 +1060,9 @@ let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) super#visit_aproj abs sproj | AProjLoans (sv', _) -> let abs = Option.get abs in - sanity_check (abs.abs_id = abs_id) meta; + sanity_check __FILE__ __LINE__ (abs.abs_id = abs_id) meta; if sv'.sv_id = sv.sv_id then ( - sanity_check (sv' = sv) meta; + sanity_check __FILE__ __LINE__ (sv' = sv) meta; update ()) else super#visit_aproj (Some abs) sproj end @@ -1070,7 +1070,7 @@ let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Sanity check *) - sanity_check !found meta; + sanity_check __FILE__ __LINE__ !found meta; (* Return *) ctx @@ -1090,7 +1090,7 @@ let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) let found = ref false in let update () = (* We update at most once *) - sanity_check (not !found) meta; + sanity_check __FILE__ __LINE__ (not !found) meta; found := true; nproj in @@ -1109,9 +1109,9 @@ let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) super#visit_aproj abs sproj | AProjBorrows (sv', _proj_ty) -> let abs = Option.get abs in - sanity_check (abs.abs_id = abs_id) meta; + sanity_check __FILE__ __LINE__ (abs.abs_id = abs_id) meta; if sv'.sv_id = sv.sv_id then ( - sanity_check (sv' = sv) meta; + sanity_check __FILE__ __LINE__ (sv' = sv) meta; update ()) else super#visit_aproj (Some abs) sproj end @@ -1119,7 +1119,7 @@ let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Sanity check *) - sanity_check !found meta; + sanity_check __FILE__ __LINE__ !found meta; (* Return *) ctx @@ -1156,7 +1156,7 @@ let no_aproj_over_symbolic_in_context (meta : Meta.meta) (sv : symbolic_value) in (* Apply *) try obj#visit_eval_ctx () ctx - with Found -> craise meta "update_aproj_loans_to_ended: failed" + with Found -> craise __FILE__ __LINE__ meta "update_aproj_loans_to_ended: failed" (** Helper function @@ -1194,7 +1194,7 @@ let get_first_non_ignored_aloan_in_abstraction (meta : Meta.meta) (abs : abs) : | VMutLoan _ -> (* The mut loan linked to the mutable borrow present in a shared * value in an abstraction should be in an AProjBorrows *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | VSharedLoan (bids, _) -> raise (FoundBorrowIds (Borrows bids)) method! visit_aproj env sproj = diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 3e1aeef2..0b7c071e 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -66,7 +66,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (** When visiting an abstraction, we remember the regions it owns to be able to properly reduce projectors when expanding symbolic values *) method! visit_abs current_abs abs = - sanity_check (Option.is_none current_abs) meta; + sanity_check __FILE__ __LINE__ (Option.is_none current_abs) meta; let current_abs = Some abs in super#visit_abs current_abs abs @@ -78,7 +78,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) method! visit_aproj current_abs aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - sanity_check (not (same_symbolic_id sv original_sv)) meta + sanity_check __FILE__ __LINE__ (not (same_symbolic_id sv original_sv)) meta | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj current_abs aproj @@ -98,7 +98,7 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (* Check if this is the symbolic value we are looking for *) if same_symbolic_id sv original_sv then ( (* There mustn't be any given back values *) - sanity_check (given_back = []) meta; + sanity_check __FILE__ __LINE__ (given_back = []) meta; (* Apply the projector *) let projected_value = apply_proj_loans_on_symbolic_expansion meta proj_regions @@ -169,7 +169,7 @@ let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) (* Count *) let replaced = ref false in let replace () = - if at_most_once then sanity_check (not !replaced) meta; + if at_most_once then sanity_check __FILE__ __LINE__ (not !replaced) meta; replaced := true; nv in @@ -218,7 +218,7 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (* Lookup the definition and check if it is an enumeration with several * variants *) let def = ctx_lookup_type_decl ctx def_id in - sanity_check + sanity_check __FILE__ __LINE__ (List.length generics.regions = List.length def.generics.regions) meta; (* Retrieve, for every variant, the list of its instantiated field types *) @@ -228,7 +228,7 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) in (* Check if there is strictly more than one variant *) if List.length variants_fields_types > 1 && not expand_enumerations then - craise meta "Not allowed to expand enumerations with several variants"; + craise __FILE__ __LINE__ meta "Not allowed to expand enumerations with several variants"; (* Initialize the expanded value for a given variant *) let initialize ((variant_id, field_types) : VariantId.id option * rty list) : symbolic_expansion = @@ -279,7 +279,7 @@ let compute_expanded_symbolic_adt_value (meta : Meta.meta) | TAssumed TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value meta boxed_ty ] | _ -> - craise meta "compute_expanded_symbolic_adt_value: unexpected combination" + craise __FILE__ __LINE__ meta "compute_expanded_symbolic_adt_value: unexpected combination" let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) @@ -314,7 +314,7 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) Some [ AsbBorrow bid; shared_asb ] else (* Not in the set: ignore *) Some [ shared_asb ] - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" else None in (* The fresh symbolic value for the shared value *) @@ -331,7 +331,7 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) else super#visit_VSymbolic env sv method! visit_EAbs proj_regions abs = - sanity_check (Option.is_none proj_regions) meta; + sanity_check __FILE__ __LINE__ (Option.is_none proj_regions) meta; let proj_regions = Some abs.regions in super#visit_EAbs proj_regions abs @@ -356,7 +356,7 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) method! visit_aproj proj_regions aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - sanity_check (not (same_symbolic_id sv original_sv)) meta + sanity_check __FILE__ __LINE__ (not (same_symbolic_id sv original_sv)) meta | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj proj_regions aproj @@ -382,7 +382,7 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) let ctx = obj#visit_eval_ctx None ctx in (* Finally, replace the projectors on loans *) let bids = !borrows in - sanity_check (not (BorrowId.Set.is_empty bids)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Set.is_empty bids)) meta; let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = @@ -400,9 +400,9 @@ let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) (region : region) (ref_ty : rty) (rkind : ref_kind) : cm_fun = fun cf ctx -> - sanity_check (region <> RErased) meta; + sanity_check __FILE__ __LINE__ (region <> RErased) meta; (* Check that we are allowed to expand the reference *) - sanity_check (not (region_in_set region ctx.ended_regions)) meta; + sanity_check __FILE__ __LINE__ (not (region_in_set region ctx.ended_regions)) meta; (* Match on the reference kind *) match rkind with | RMut -> @@ -456,7 +456,7 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = fun ctx -> - sanity_check (see_cf_l <> []) meta; + sanity_check __FILE__ __LINE__ (see_cf_l <> []) meta; (* Apply the symbolic expansion in the context and call the continuation *) let resl = List.map @@ -490,9 +490,9 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) match resl with | Some _ :: _ -> Some (List.map Option.get resl) | None :: _ -> - List.iter (fun res -> sanity_check (res = None) meta) resl; + List.iter (fun res -> sanity_check __FILE__ __LINE__ (res = None) meta) resl; None - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in (* Synthesize and return *) let seel = List.map fst see_cf_l in @@ -506,7 +506,7 @@ let expand_symbolic_bool (config : config) (meta : Meta.meta) let original_sv = sv in let original_sv_place = sv_place in let rty = original_sv.sv_ty in - sanity_check (rty = TLiteral TBool) meta; + sanity_check __FILE__ __LINE__ (rty = TLiteral TBool) meta; (* Expand the symbolic value to true or false and continue execution *) let see_true = SeLiteral (VBool true) in let see_false = SeLiteral (VBool false) in @@ -556,7 +556,7 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) expand_symbolic_value_borrow config meta original_sv original_sv_place region ref_ty rkind cf ctx | _ -> - craise meta + craise __FILE__ __LINE__ meta ("expand_symbolic_value_no_branching: unexpected type: " ^ show_rty rty) in @@ -573,7 +573,7 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* Sanity check: the symbolic value has disappeared *) - sanity_check (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta) + sanity_check __FILE__ __LINE__ (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta) in (* Continue *) cc cf ctx @@ -603,14 +603,14 @@ let expand_symbolic_adt (config : config) (meta : Meta.meta) let seel = List.map (fun see -> (Some see, cf_branches)) seel in apply_branching_symbolic_expansions_non_borrow config meta original_sv original_sv_place seel cf_after_join ctx - | _ -> craise meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) + | _ -> craise __FILE__ __LINE__ meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) let expand_symbolic_int (config : config) (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) (int_type : integer_type) (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) - sanity_check (sv.sv_ty = TLiteral (TInteger int_type)) meta; + sanity_check __FILE__ __LINE__ (sv.sv_ty = TLiteral (TInteger int_type)) meta; (* For all the branches of the switch, we expand the symbolic value * to the value given by the branch and execute the branch statement. * For the otherwise branch, we leave the symbolic value as it is @@ -678,16 +678,16 @@ let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : (match def.kind with | Struct _ | Enum ([] | [ _ ]) -> () | Enum (_ :: _) -> - craise meta + craise __FILE__ __LINE__ meta ("Attempted to greedily expand a symbolic enumeration with > \ 1 variants (option [greedy_expand_symbolics_with_borrows] \ of [config]): " ^ name_to_string ctx def.name) | Opaque -> - craise meta "Attempted to greedily expand an opaque type"); + craise __FILE__ __LINE__ meta "Attempted to greedily expand an opaque type"); (* Also, we need to check if the definition is recursive *) if ctx_type_decl_is_rec ctx def_id then - craise meta + craise __FILE__ __LINE__ meta ("Attempted to greedily expand a recursive definition (option \ [greedy_expand_symbolics_with_borrows] of [config]): " ^ name_to_string ctx def.name) @@ -697,10 +697,10 @@ let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : expand_symbolic_value_no_branching config meta sv None | TAdt (TAssumed (TArray | TSlice | TStr), _) -> (* We can't expand those *) - craise meta + craise __FILE__ __LINE__ meta "Attempted to greedily expand an ADT which can't be expanded " | TVar _ | TLiteral _ | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in (* Compose and continue *) comp cc expand cf ctx diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 3d01024b..59f74ad8 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -55,11 +55,11 @@ let read_place (meta : Meta.meta) (access : access_kind) (p : place) fun ctx -> let v = read_place meta access p ctx in (* Check that there are no bottoms in the value *) - cassert + cassert __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value"; (* Check that there are no reserved borrows in the value *) - cassert + cassert __FILE__ __LINE__ (not (reserved_in_value v)) meta "There should be no reserved borrows in the value"; (* Call the continuation *) @@ -107,11 +107,11 @@ let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) | TChar, VChar v -> { value = VLiteral (VChar v); ty = TLiteral ty } | TInteger int_ty, VScalar v -> (* Check the type and the ranges *) - sanity_check (int_ty = v.int_ty) meta; - sanity_check (check_scalar_value_in_range v) meta; + sanity_check __FILE__ __LINE__ (int_ty = v.int_ty) meta; + sanity_check __FILE__ __LINE__ (check_scalar_value_in_range v) meta; { value = VLiteral (VScalar v); ty = TLiteral ty } (* Remaining cases (invalid) *) - | _, _ -> craise meta "Improperly typed constant value" + | _, _ -> craise __FILE__ __LINE__ meta "Improperly typed constant value" (** Copy a value, and return the resulting value. @@ -142,9 +142,9 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) (* Sanity check *) (match v.ty with | TAdt (TAssumed TBox, _) -> - exec_raise meta "Can't copy an assumed value other than Option" + exec_raise __FILE__ __LINE__ meta "Can't copy an assumed value other than Option" | TAdt (TAdtId _, _) as ty -> - sanity_check (allow_adt_copy || ty_is_primitively_copyable ty) meta + sanity_check __FILE__ __LINE__ (allow_adt_copy || ty_is_primitively_copyable ty) meta | TAdt (TTuple, _) -> () (* Ok *) | TAdt ( TAssumed (TSlice | TArray), @@ -154,17 +154,17 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) const_generics = []; trait_refs = []; } ) -> - exec_assert + exec_assert __FILE__ __LINE__ (ty_is_primitively_copyable ty) meta "The type is not primitively copyable" - | _ -> exec_raise meta "Unreachable"); + | _ -> exec_raise __FILE__ __LINE__ meta "Unreachable"); let ctx, fields = List.fold_left_map (copy_value meta allow_adt_copy config) ctx av.field_values in (ctx, { v with value = VAdt { av with field_values = fields } }) - | VBottom -> exec_raise meta "Can't copy ⊥" + | VBottom -> exec_raise __FILE__ __LINE__ meta "Can't copy ⊥" | VBorrow bc -> ( (* We can only copy shared borrows *) match bc with @@ -174,13 +174,13 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) let bid' = fresh_borrow_id () in let ctx = InterpreterBorrows.reborrow_shared meta bid bid' ctx in (ctx, { v with value = VBorrow (VSharedBorrow bid') }) - | VMutBorrow (_, _) -> exec_raise meta "Can't copy a mutable borrow" + | VMutBorrow (_, _) -> exec_raise __FILE__ __LINE__ meta "Can't copy a mutable borrow" | VReservedMutBorrow _ -> - exec_raise meta "Can't copy a reserved mut borrow") + exec_raise __FILE__ __LINE__ meta "Can't copy a reserved mut borrow") | VLoan lc -> ( (* We can only copy shared loans *) match lc with - | VMutLoan _ -> exec_raise meta "Can't copy a mutable loan" + | VMutLoan _ -> exec_raise __FILE__ __LINE__ meta "Can't copy a mutable loan" | VSharedLoan (_, sv) -> (* We don't copy the shared loan: only the shared value inside *) copy_value meta allow_adt_copy config ctx sv) @@ -189,7 +189,7 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) * Note that in the general case, copy is a trait: copying values * thus requires calling the proper function. Here, we copy values * for very simple types such as integers, shared borrows, etc. *) - cassert + cassert __FILE__ __LINE__ (ty_is_primitively_copyable (Substitute.erase_regions sp.sv_ty)) meta "Not primitively copyable"; (* If the type is copyable, we simply return the current value. Side @@ -319,14 +319,14 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) let e = cf cv ctx in (* If we are synthesizing a symbolic AST, it means that we are in symbolic mode: the value of the const generic is necessarily symbolic. *) - sanity_check (e = None || is_symbolic cv.value) meta; + sanity_check __FILE__ __LINE__ (e = None || is_symbolic cv.value) meta; (* We have to wrap the generated expression *) match e with | None -> None | Some e -> (* If we are synthesizing a symbolic AST, it means that we are in symbolic mode: the value of the const generic is necessarily symbolic. *) - sanity_check (is_symbolic cv.value) meta; + sanity_check __FILE__ __LINE__ (is_symbolic cv.value) meta; (* *) Some (SymbolicAst.IntroSymbolic @@ -335,7 +335,7 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) value_as_symbolic meta cv.value, SymbolicAst.VaCgValue vid, e ))) - | CFnPtr _ -> craise meta "TODO: error message") + | CFnPtr _ -> craise __FILE__ __LINE__ meta "TODO: error message") | Copy p -> (* Access the value *) let access = Read in @@ -344,10 +344,10 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) let copy cf v : m_fun = fun ctx -> (* Sanity checks *) - exec_assert + exec_assert __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions v)) meta "Can not copy a value containing bottom"; - sanity_check + sanity_check __FILE__ __LINE__ (Option.is_none (find_first_primitively_copyable_sv_with_borrows ctx.type_ctx.type_infos v)) @@ -368,7 +368,7 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) let move cf v : m_fun = fun ctx -> (* Check that there are no bottoms in the value we are about to move *) - exec_assert + exec_assert __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value we are about to move"; let bottom : typed_value = { value = VBottom; ty = v.ty } in @@ -420,7 +420,7 @@ let eval_two_operands (config : config) (meta : Meta.meta) (op1 : operand) (op2 : operand) (cf : typed_value * typed_value -> m_fun) : m_fun = let eval_op = eval_operands config meta [ op1; op2 ] in let use_res cf res = - match res with [ v1; v2 ] -> cf (v1, v2) | _ -> craise meta "Unreachable" + match res with [ v1; v2 ] -> cf (v1, v2) | _ -> craise __FILE__ __LINE__ meta "Unreachable" in comp eval_op use_res cf @@ -441,7 +441,7 @@ let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) | ( Cast (CastScalar (TInteger src_ty, TInteger tgt_ty)), VLiteral (VScalar sv) ) -> ( (* Cast between integers *) - sanity_check (src_ty = sv.int_ty) meta; + sanity_check __FILE__ __LINE__ (src_ty = sv.int_ty) meta; let i = sv.value in match mk_scalar tgt_ty i with | Error _ -> cf (Error EPanic) @@ -463,12 +463,12 @@ let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) let b = if Z.of_int 0 = sv.value then false else if Z.of_int 1 = sv.value then true - else exec_raise meta "Conversion from int to bool: out of range" + else exec_raise __FILE__ __LINE__ meta "Conversion from int to bool: out of range" in let value = VLiteral (VBool b) in let ty = TLiteral TBool in cf (Ok { ty; value }) - | _ -> exec_raise meta "Invalid input for unop" + | _ -> exec_raise __FILE__ __LINE__ meta "Invalid input for unop" in comp eval_op apply cf @@ -486,7 +486,7 @@ let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) | Not, (TLiteral TBool as lty) -> lty | Neg, (TLiteral (TInteger _) as lty) -> lty | Cast (CastScalar (_, tgt_ty)), _ -> TLiteral tgt_ty - | _ -> exec_raise meta "Invalid input for unop" + | _ -> exec_raise __FILE__ __LINE__ meta "Invalid input for unop" in let res_sv = { sv_id = res_sv_id; sv_ty = res_sv_ty } in (* Call the continuation *) @@ -514,9 +514,9 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) * The remaining binops only operate on scalars. *) if binop = Eq || binop = Ne then ( (* Equality operations *) - exec_assert (v1.ty = v2.ty) meta "TODO: error message"; + exec_assert __FILE__ __LINE__ (v1.ty = v2.ty) meta "TODO: error message"; (* Equality/inequality check is primitive only for a subset of types *) - exec_assert + exec_assert __FILE__ __LINE__ (ty_is_primitively_copyable v1.ty) meta "Type is not primitively copyable"; let b = v1 = v2 in @@ -533,7 +533,7 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) match binop with | Lt | Le | Ge | Gt -> (* The two operands must have the same type and the result is a boolean *) - sanity_check (sv1.int_ty = sv2.int_ty) meta; + sanity_check __FILE__ __LINE__ (sv1.int_ty = sv2.int_ty) meta; let b = match binop with | Lt -> Z.lt sv1.value sv2.value @@ -542,14 +542,14 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) | Gt -> Z.gt sv1.value sv2.value | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr | Shl | Shr | Ne | Eq -> - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in Ok ({ value = VLiteral (VBool b); ty = TLiteral TBool } : typed_value) | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> ( (* The two operands must have the same type and the result is an integer *) - sanity_check (sv1.int_ty = sv2.int_ty) meta; + sanity_check __FILE__ __LINE__ (sv1.int_ty = sv2.int_ty) meta; let res = match binop with | Div -> @@ -566,7 +566,7 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) | BitAnd -> raise Unimplemented | BitOr -> raise Unimplemented | Lt | Le | Ge | Gt | Shl | Shr | Ne | Eq -> - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in match res with | Error _ -> Error EPanic @@ -577,8 +577,8 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) ty = TLiteral (TInteger sv1.int_ty); }) | Shl | Shr -> raise Unimplemented - | Ne | Eq -> craise meta "Unreachable") - | _ -> craise meta "Invalid inputs for binop" + | Ne | Eq -> craise __FILE__ __LINE__ meta "Unreachable") + | _ -> craise __FILE__ __LINE__ meta "Invalid inputs for binop" let eval_binary_op_concrete (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) (op2 : operand) @@ -607,9 +607,9 @@ let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) let res_sv_ty = if binop = Eq || binop = Ne then ( (* Equality operations *) - sanity_check (v1.ty = v2.ty) meta; + sanity_check __FILE__ __LINE__ (v1.ty = v2.ty) meta; (* Equality/inequality check is primitive only for a subset of types *) - exec_assert + exec_assert __FILE__ __LINE__ (ty_is_primitively_copyable v1.ty) meta "The type is not primitively copyable"; TLiteral TBool) @@ -619,17 +619,17 @@ let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) | TLiteral (TInteger int_ty1), TLiteral (TInteger int_ty2) -> ( match binop with | Lt | Le | Ge | Gt -> - sanity_check (int_ty1 = int_ty2) meta; + sanity_check __FILE__ __LINE__ (int_ty1 = int_ty2) meta; TLiteral TBool | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> - sanity_check (int_ty1 = int_ty2) meta; + sanity_check __FILE__ __LINE__ (int_ty1 = int_ty2) meta; TLiteral (TInteger int_ty1) | Shl | Shr -> (* The number of bits can be of a different integer type than the operand *) TLiteral (TInteger int_ty1) - | Ne | Eq -> craise meta "Unreachable") - | _ -> craise meta "Invalid inputs for binop" + | Ne | Eq -> craise __FILE__ __LINE__ meta "Unreachable") + | _ -> craise __FILE__ __LINE__ meta "Invalid inputs for binop" in let res_sv = { sv_id = res_sv_id; sv_ty = res_sv_ty } in (* Call the continuattion *) @@ -659,14 +659,14 @@ let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) In practice this restricted the behaviour too much, so for now we forbid them. *) - sanity_check (bkind <> BShallow) meta; + sanity_check __FILE__ __LINE__ (bkind <> BShallow) meta; (* Access the value *) let access = match bkind with | BShared | BShallow -> Read | BTwoPhaseMut -> Write - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let expand_prim_copy = false in @@ -698,7 +698,7 @@ let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) match bkind with | BShared | BShallow -> RShared | BTwoPhaseMut -> RMut - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let rv_ty = TRef (RErased, v.ty, ref_kind) in let bc = @@ -708,7 +708,7 @@ let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) handle shallow borrows like shared borrows *) VSharedBorrow bid | BTwoPhaseMut -> VReservedMutBorrow bid - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let rv : typed_value = { value = VBorrow bc; ty = rv_ty } in (* Continue *) @@ -765,7 +765,7 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) | TAdtId def_id -> (* Sanity checks *) let type_decl = ctx_lookup_type_decl ctx def_id in - sanity_check + sanity_check __FILE__ __LINE__ (List.length type_decl.generics.regions = List.length generics.regions) meta; @@ -773,7 +773,7 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) AssociatedTypes.ctx_adt_get_inst_norm_field_etypes meta ctx def_id opt_variant_id generics in - sanity_check + sanity_check __FILE__ __LINE__ (expected_field_types = List.map (fun (v : typed_value) -> v.ty) values) meta; @@ -785,15 +785,15 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) let aggregated : typed_value = { value = VAdt av; ty = aty } in (* Call the continuation *) cf aggregated ctx - | TAssumed _ -> craise meta "Unreachable") + | TAssumed _ -> craise __FILE__ __LINE__ meta "Unreachable") | AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun (v : typed_value) -> v.ty = ety) values) meta; (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in - sanity_check (len = Z.of_int (List.length values)) meta; + sanity_check __FILE__ __LINE__ (len = Z.of_int (List.length values)) meta; let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in let ty = TAdt (TAssumed TArray, generics) in (* In order to generate a better AST, we introduce a symbolic @@ -809,7 +809,7 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (* Introduce the symbolic value in the AST *) let sv = ValuesUtils.value_as_symbolic meta saggregated.value in Some (SymbolicAst.IntroSymbolic (ctx, None, sv, VaArray values, e))) - | AggregatedClosure _ -> craise meta "Closures are not supported yet" + | AggregatedClosure _ -> craise __FILE__ __LINE__ meta "Closures are not supported yet" in (* Compose and apply *) comp eval_ops compute cf @@ -834,10 +834,10 @@ let eval_rvalue_not_global (config : config) (meta : Meta.meta) | Aggregate (aggregate_kind, ops) -> comp_wrap (eval_rvalue_aggregate config meta aggregate_kind ops) ctx | Discriminant _ -> - craise meta + craise __FILE__ __LINE__ meta "Unreachable: discriminant reads should have been eliminated from the \ AST" - | Global _ -> craise meta "Unreachable" + | Global _ -> craise __FILE__ __LINE__ meta "Unreachable" let eval_fake_read (config : config) (meta : Meta.meta) (p : place) : cm_fun = fun cf ctx -> @@ -847,7 +847,7 @@ let eval_fake_read (config : config) (meta : Meta.meta) (p : place) : cm_fun = in let cf_continue cf v : m_fun = fun ctx -> - cassert + cassert __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions v)) meta "Fake read: the value contains bottom"; cf ctx diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index d369aef9..17487401 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -54,10 +54,10 @@ let eval_loop_concrete (meta : Meta.meta) (eval_loop_body : st_cm_fun) : * {!Unit} would account for the first iteration of the loop. * We prefer to write it this way for consistency and sanity, * though. *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> (* We can't get there: this is only used in symbolic mode *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in (* Apply *) @@ -160,7 +160,7 @@ let eval_loop_symbolic (config : config) (meta : meta) cf res ctx | Continue i -> (* We don't support nested loops for now *) - cassert (i = 0) meta "Nested loops are not supported yet"; + cassert __FILE__ __LINE__ (i = 0) meta "Nested loops are not supported yet"; log#ldebug (lazy ("eval_loop_symbolic: about to match the fixed-point context \ @@ -178,7 +178,7 @@ let eval_loop_symbolic (config : config) (meta : meta) (* For why we can't get [Unit], see the comments inside {!eval_loop_concrete}. For [EndEnterLoop] and [EndContinue]: we don't support nested loops for now. *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in let loop_expr = eval_loop_body cf_loop fp_ctx in @@ -212,7 +212,7 @@ let eval_loop_symbolic (config : config) (meta : meta) match av.value with | ABorrow _ -> true | ALoan _ -> false - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let borrows, loans = List.partition is_borrow abs.avalues in @@ -221,10 +221,10 @@ let eval_loop_symbolic (config : config) (meta : meta) (fun (av : typed_avalue) -> match av.value with | ABorrow (AMutBorrow (bid, child_av)) -> - sanity_check (is_aignored child_av.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child_av.value) meta; Some (bid, child_av.ty) | ABorrow (ASharedBorrow _) -> None - | _ -> craise meta "Unreachable") + | _ -> craise __FILE__ __LINE__ meta "Unreachable") borrows in let borrows = ref (BorrowId.Map.of_list borrows) in @@ -234,10 +234,10 @@ let eval_loop_symbolic (config : config) (meta : meta) (fun (av : typed_avalue) -> match av.value with | ALoan (AMutLoan (bid, child_av)) -> - sanity_check (is_aignored child_av.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child_av.value) meta; Some bid | ALoan (ASharedLoan _) -> None - | _ -> craise meta "Unreachable") + | _ -> craise __FILE__ __LINE__ meta "Unreachable") loans in @@ -253,7 +253,7 @@ let eval_loop_symbolic (config : config) (meta : meta) ty) loan_ids in - sanity_check (BorrowId.Map.is_empty !borrows) meta; + sanity_check __FILE__ __LINE__ (BorrowId.Map.is_empty !borrows) meta; given_back_tys in diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 660e542d..a8a64264 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -380,7 +380,7 @@ let ctx_split_fixed_new (meta : Meta.meta) (fixed_ids : ids_sets) let new_absl = List.map (fun ee -> - match ee with EAbs abs -> abs | _ -> craise meta "Unreachable") + match ee with EAbs abs -> abs | _ -> craise __FILE__ __LINE__ meta "Unreachable") new_absl in let new_dummyl = @@ -388,7 +388,7 @@ let ctx_split_fixed_new (meta : Meta.meta) (fixed_ids : ids_sets) (fun ee -> match ee with | EBinding (BDummy _, v) -> v - | _ -> craise meta "Unreachable") + | _ -> craise __FILE__ __LINE__ meta "Unreachable") new_dummyl in (filt_env, new_absl, new_dummyl) diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 7ddf55c1..39add08e 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -144,7 +144,7 @@ let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) match av.value with | ABorrow _ -> true | ALoan _ -> false - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in let aborrows, aloans = List.partition is_borrow abs.avalues in @@ -157,13 +157,13 @@ let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) let get_borrow_id (av : typed_avalue) : BorrowId.id = match av.value with | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in let get_loan_id (av : typed_avalue) : BorrowId.id = match av.value with | ALoan (AMutLoan (lid, _)) -> lid | ALoan (ASharedLoan (lids, _, _)) -> BorrowId.Set.min_elt lids - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in (* We use ordered maps to reorder the borrows and loans *) let reorder (get_bid : typed_avalue -> BorrowId.id) @@ -268,12 +268,12 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : borrow_substs := (lid, nlid) :: !borrow_substs; (* Rem.: the below sanity checks are not really necessary *) - sanity_check (AbstractionId.Set.is_empty abs.parents) meta; - sanity_check (abs.original_parents = []) meta; - sanity_check (RegionId.Set.is_empty abs.ancestors_regions) meta; + sanity_check __FILE__ __LINE__ (AbstractionId.Set.is_empty abs.parents) meta; + sanity_check __FILE__ __LINE__ (abs.original_parents = []) meta; + sanity_check __FILE__ __LINE__ (RegionId.Set.is_empty abs.ancestors_regions) meta; (* Introduce the new abstraction for the shared values *) - cassert (ty_no_regions sv.ty) meta "Nested borrows are not supported yet"; + cassert __FILE__ __LINE__ (ty_no_regions sv.ty) meta "Nested borrows are not supported yet"; let rty = sv.ty in (* Create the shared loan child *) @@ -324,7 +324,7 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : let collect_shared_values_in_abs (abs : abs) : unit = let collect_shared_value lids (sv : typed_value) = (* Sanity check: we don't support nested borrows for now *) - sanity_check (not (value_has_borrows ctx sv.value)) meta; + sanity_check __FILE__ __LINE__ (not (value_has_borrows ctx sv.value)) meta; (* Filter the loan ids whose corresponding borrows appear in abstractions (see the documentation of the function) *) @@ -358,7 +358,7 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : TODO: implement this more general behavior. *) method! visit_symbolic_value env sv = - cassert + cassert __FILE__ __LINE__ (not (symbolic_value_has_borrows ctx sv)) meta "There should be no symbolic values with borrows inside the \ @@ -478,15 +478,15 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) | Return | Panic | Break _ -> None | Unit -> (* See the comment in {!eval_loop} *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Continue i -> (* For now we don't support continues to outer loops *) - cassert (i = 0) meta "Continues to outer loops not supported yet"; + cassert __FILE__ __LINE__ (i = 0) meta "Continues to outer loops not supported yet"; register_ctx ctx; None | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> (* We don't support nested loops for now *) - craise meta "Nested loops are not supported for now" + craise __FILE__ __LINE__ meta "Nested loops are not supported for now" in (* The fixed ids. They are the ids of the original ctx, after we ended @@ -580,7 +580,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) log#ldebug (lazy "compute_fixed_point: equiv_ctx:"); let fixed_ids = compute_fixed_ids [ ctx1; ctx2 ] in let check_equivalent = true in - let lookup_shared_value _ = craise meta "Unreachable" in + let lookup_shared_value _ = craise __FILE__ __LINE__ meta "Unreachable" in Option.is_some (match_ctxs meta check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx1 ctx2) @@ -588,7 +588,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) let max_num_iter = Config.loop_fixed_point_max_num_iters in let rec compute_fixed_point (ctx : eval_ctx) (i0 : int) (i : int) : eval_ctx = if i = 0 then - craise meta + craise __FILE__ __LINE__ meta ("Could not compute a loop fixed point in " ^ string_of_int i0 ^ " iterations") else @@ -639,10 +639,10 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> - sanity_check (loop_id' = loop_id) meta; - sanity_check (kind = LoopSynthInput) meta; + sanity_check __FILE__ __LINE__ (loop_id' = loop_id) meta; + sanity_check __FILE__ __LINE__ (kind = LoopSynthInput) meta; (* The abstractions introduced so far should be endable *) - sanity_check (abs.can_end = true) meta; + sanity_check __FILE__ __LINE__ (abs.can_end = true) meta; add_aid abs.abs_id; abs | _ -> abs @@ -675,12 +675,12 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) None | Break _ -> (* We enforce that we can't get there: see {!PrePasses.remove_loop_breaks} *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Unit | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> (* For why we can't get [Unit], see the comments inside {!eval_loop_concrete}. For [EndEnterLoop] and [EndContinue]: we don't support nested loops for now. *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Return -> log#ldebug (lazy "compute_loop_entry_fixed_point: cf_loop: Return"); (* Should we consume the return value and pop the frame? @@ -699,7 +699,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) in (* By default, the [SynthInput] abs can't end *) let ctx = ctx_set_abs_can_end meta ctx abs_id true in - sanity_check + sanity_check __FILE__ __LINE__ (let abs = ctx_lookup_abs ctx abs_id in abs.kind = SynthInput rg_id) meta; @@ -725,7 +725,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) let _ = RegionGroupId.Map.iter (fun _ ids -> - cassert + cassert __FILE__ __LINE__ (AbstractionId.Set.disjoint !aids_union ids) meta "The sets of abstractions we need to end per region group are not \ @@ -736,7 +736,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (* We also check that all the regions need to end - this is not necessary per se, but if it doesn't happen it is bizarre and worth investigating... *) - sanity_check (AbstractionId.Set.equal !aids_union !fp_aids) meta; + sanity_check __FILE__ __LINE__ (AbstractionId.Set.equal !aids_union !fp_aids) meta; (* Merge the abstractions which need to be merged, and compute the map from region id to abstraction id *) @@ -794,7 +794,7 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) fp := fp'; id0 := id0'; () - with ValueMatchFailure _ -> craise meta "Unexpected") + with ValueMatchFailure _ -> craise __FILE__ __LINE__ meta "Unexpected") ids; (* Register the mapping *) let abs = ctx_lookup_abs !fp !id0 in @@ -827,8 +827,8 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> - sanity_check (loop_id' = loop_id) meta; - sanity_check (kind = LoopSynthInput) meta; + sanity_check __FILE__ __LINE__ (loop_id' = loop_id) meta; + sanity_check __FILE__ __LINE__ (kind = LoopSynthInput) meta; let kind : abs_kind = if remove_rg_id then Loop (loop_id, None, LoopSynthInput) else abs.kind @@ -897,7 +897,7 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) match snd (lookup_loan meta ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in let lookup_in_src id = lookup_shared_loan id src_ctx in @@ -957,7 +957,7 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) ids.loan_ids in (* Check that the loan and borrows are related *) - sanity_check (BorrowId.Set.equal ids.borrow_ids loan_ids) meta) + sanity_check __FILE__ __LINE__ (BorrowId.Set.equal ids.borrow_ids loan_ids) meta) new_absl; (* For every target abstraction (going back to the [list_nth_mut] example, @@ -1084,7 +1084,7 @@ let compute_fp_ctx_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) match snd (lookup_loan meta ek_all bid fp_ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in self#visit_typed_value env v diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 020e812a..3b1767e8 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -27,7 +27,7 @@ let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) match av.value with | ABorrow _ -> true | ALoan _ -> false - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in let aborrows, aloans = List.partition is_borrow abs.avalues in @@ -40,13 +40,13 @@ let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) let get_borrow_id (av : typed_avalue) : BorrowId.id = match av.value with | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in let get_loan_id (av : typed_avalue) : BorrowId.id = match av.value with | ALoan (AMutLoan (lid, _)) -> lid | ALoan (ASharedLoan (lids, _, _)) -> BorrowId.Set.min_elt lids - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in (* We use ordered maps to reorder the borrows and loans *) let reorder (get_bid : typed_avalue -> BorrowId.id) @@ -316,8 +316,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) *) let merge_amut_borrows id ty0 child0 _ty1 child1 = (* Sanity checks *) - sanity_check (is_aignored child0.value) meta; - sanity_check (is_aignored child1.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child0.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child1.value) meta; (* We need to pick a type for the avalue. The types on the left and on the right may use different regions: it doesn't really matter (here, we pick @@ -335,8 +335,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) let _ = let _, ty0, _ = ty_as_ref ty0 in let _, ty1, _ = ty_as_ref ty1 in - sanity_check (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) meta; - sanity_check (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) meta + sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) meta; + sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) meta in (* Same remarks as for [merge_amut_borrows] *) @@ -347,8 +347,8 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) let merge_amut_loans id ty0 child0 _ty1 child1 = (* Sanity checks *) - sanity_check (is_aignored child0.value) meta; - sanity_check (is_aignored child1.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child0.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child1.value) meta; (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in let child = child0 in @@ -358,15 +358,15 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) let merge_ashared_loans ids ty0 (sv0 : typed_value) child0 _ty1 (sv1 : typed_value) child1 = (* Sanity checks *) - sanity_check (is_aignored child0.value) meta; - sanity_check (is_aignored child1.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child0.value) meta; + sanity_check __FILE__ __LINE__ (is_aignored child1.value) meta; (* Same remarks as for [merge_amut_borrows]. This time we need to also merge the shared values. We rely on the join matcher [JM] to do so. *) - sanity_check (not (value_has_loans_or_borrows ctx sv0.value)) meta; - sanity_check (not (value_has_loans_or_borrows ctx sv1.value)) meta; + sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv0.value)) meta; + sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv1.value)) meta; let ty = ty0 in let child = child0 in let sv = M.match_typed_values ctx ctx sv0 sv1 in @@ -398,7 +398,7 @@ let collapse_ctx_with_merge (meta : Meta.meta) (loop_id : LoopId.id) (old_ids : ids_sets) (ctx : eval_ctx) : eval_ctx = let merge_funs = mk_collapse_ctx_merge_duplicate_funs meta loop_id ctx in try collapse_ctx meta loop_id (Some merge_funs) old_ids ctx - with ValueMatchFailure _ -> craise meta "Unexpected" + with ValueMatchFailure _ -> craise __FILE__ __LINE__ meta "Unexpected" let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) (ctx1 : eval_ctx) : ctx_or_update = @@ -435,16 +435,16 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) match ee with | EBinding (BVar _, _) -> (* Variables are necessarily in the prefix *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | EBinding (BDummy did, _) -> - sanity_check (not (DummyVarId.Set.mem did fixed_ids.dids)) meta + sanity_check __FILE__ __LINE__ (not (DummyVarId.Set.mem did fixed_ids.dids)) meta | EAbs abs -> - sanity_check + sanity_check __FILE__ __LINE__ (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) meta | EFrame -> (* This should have been eliminated *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in List.iter check_valid env0; List.iter check_valid env1; @@ -481,7 +481,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) are not in the prefix anymore *) if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Still in the prefix: match the values *) - cassert (b0 = b1) meta + cassert __FILE__ __LINE__ (b0 = b1) meta "Bindings are not the same. We are not in the prefix anymore"; let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in @@ -504,7 +504,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (* Variable bindings *must* be in the prefix and consequently their ids must be the same *) - cassert (b0 = b1) meta + cassert __FILE__ __LINE__ (b0 = b1) meta "Variable bindings *must* be in the prefix and consequently their\n\ \ ids must be the same"; (* Match the values *) @@ -527,7 +527,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (* Same as for the dummy values: there are two cases *) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( (* Still in the prefix: the abstractions must be the same *) - cassert (abs0 = abs1) meta "The abstractions are not the same"; + cassert __FILE__ __LINE__ (abs0 = abs1) meta "The abstractions are not the same"; (* Continue *) abs :: join_prefixes env0' env1') else (* Not in the prefix anymore *) @@ -542,7 +542,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) let env0, env1 = match (env0, env1) with | EFrame :: env0, EFrame :: env1 -> (env0, env1) - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in log#ldebug @@ -682,7 +682,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) | LoansInRight bids -> InterpreterBorrows.end_borrows_no_synth config meta bids ctx | AbsInRight _ | AbsInLeft _ | LoanInLeft _ | LoansInLeft _ -> - craise meta "Unexpected" + craise __FILE__ __LINE__ meta "Unexpected" in join_one_aux ctx in diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 1a6e6926..9c017f19 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -43,7 +43,7 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) match Id0.Map.find_opt id0 !map with | None -> () | Some set -> - sanity_check + sanity_check __FILE__ __LINE__ ((not check_not_already_registered) || not (Id1.Set.mem id1 set)) meta); (* Update the mapping *) @@ -54,8 +54,8 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) | None -> Some (Id1.Set.singleton id1) | Some ids -> (* Sanity check *) - sanity_check (not check_singleton_sets) meta; - sanity_check + sanity_check __FILE__ __LINE__ (not check_singleton_sets) meta; + sanity_check __FILE__ __LINE__ ((not check_not_already_registered) || not (Id1.Set.mem id1 ids)) meta; @@ -96,7 +96,7 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) | AIgnoredSharedLoan child -> (* Ignore the id of the loan, if there is *) self#visit_typed_avalue abs_id child - | AEndedMutLoan _ | AEndedSharedLoan _ -> craise meta "Unreachable" + | AEndedMutLoan _ | AEndedSharedLoan _ -> craise __FILE__ __LINE__ meta "Unreachable" (** Make sure we don't register the ignored ids *) method! visit_aborrow_content abs_id bc = @@ -109,7 +109,7 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) -> (* Ignore the id of the borrow, if there is *) self#visit_typed_avalue abs_id child - | AEndedMutBorrow _ | AEndedSharedBorrow -> craise meta "Unreachable" + | AEndedMutBorrow _ | AEndedSharedBorrow -> craise __FILE__ __LINE__ meta "Unreachable" method! visit_borrow_id abs_id bid = register_borrow_id abs_id bid method! visit_loan_id abs_id lid = register_loan_id abs_id lid @@ -150,9 +150,9 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) let match_rec = match_types meta match_distinct_types match_regions in match (ty0, ty1) with | TAdt (id0, generics0), TAdt (id1, generics1) -> - sanity_check (id0 = id1) meta; - sanity_check (generics0.const_generics = generics1.const_generics) meta; - sanity_check (generics0.trait_refs = generics1.trait_refs) meta; + sanity_check __FILE__ __LINE__ (id0 = id1) meta; + sanity_check __FILE__ __LINE__ (generics0.const_generics = generics1.const_generics) meta; + sanity_check __FILE__ __LINE__ (generics0.trait_refs = generics1.trait_refs) meta; let id = id0 in let const_generics = generics1.const_generics in let trait_refs = generics1.trait_refs in @@ -169,17 +169,17 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) let generics = { regions; types; const_generics; trait_refs } in TAdt (id, generics) | TVar vid0, TVar vid1 -> - sanity_check (vid0 = vid1) meta; + sanity_check __FILE__ __LINE__ (vid0 = vid1) meta; let vid = vid0 in TVar vid | TLiteral lty0, TLiteral lty1 -> - sanity_check (lty0 = lty1) meta; + sanity_check __FILE__ __LINE__ (lty0 = lty1) meta; ty0 | TNever, TNever -> ty0 | TRef (r0, ty0, k0), TRef (r1, ty1, k1) -> let r = match_regions r0 r1 in let ty = match_rec ty0 ty1 in - sanity_check (k0 = k1) meta; + sanity_check __FILE__ __LINE__ (k0 = k1) meta; let k = k0 in TRef (r, ty, k) | _ -> match_distinct_types ty0 ty1 @@ -213,8 +213,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct { value; ty = v1.ty } else ( (* For now, we don't merge ADTs which contain borrows *) - sanity_check (not (value_has_borrows v0.value)) M.meta; - sanity_check (not (value_has_borrows v1.value)) M.meta; + sanity_check __FILE__ __LINE__ (not (value_has_borrows v0.value)) M.meta; + sanity_check __FILE__ __LINE__ (not (value_has_borrows v1.value)) M.meta; (* Merge *) M.match_distinct_adts ctx0 ctx1 ty av0 av1) | VBottom, VBottom -> v0 @@ -229,7 +229,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> let bv = match_rec bv0 bv1 in - cassert + cassert __FILE__ __LINE__ (not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) @@ -246,7 +246,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct trying to match a reserved borrow, which shouldn't happen because reserved borrow should be eliminated very quickly - they are introduced just before function calls which activate them *) - craise M.meta "Unexpected" + craise __FILE__ __LINE__ M.meta "Unexpected" in { value = VBorrow bc; ty } | VLoan lc0, VLoan lc1 -> @@ -256,7 +256,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (lc0, lc1) with | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in - cassert + cassert __FILE__ __LINE__ (not (value_has_borrows sv.value)) M.meta "TODO: error message"; let ids, sv = M.match_shared_loans ctx0 ctx1 ty ids0 ids1 sv in @@ -265,18 +265,18 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let id = M.match_mut_loans ctx0 ctx1 ty id0 id1 in VMutLoan id | VSharedLoan _, VMutLoan _ | VMutLoan _, VSharedLoan _ -> - craise M.meta "Unreachable" + craise __FILE__ __LINE__ M.meta "Unreachable" in { value = VLoan lc; ty = v1.ty } | VSymbolic sv0, VSymbolic sv1 -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - cassert + cassert __FILE__ __LINE__ (not (value_has_borrows v0.value)) M.meta "Nested borrows are not supported yet and all the symbolic values \ containing borrows are currently forced to be eagerly expanded"; - cassert + cassert __FILE__ __LINE__ (not (value_has_borrows v1.value)) M.meta "Nested borrows are not supported yet and all the symbolic values \ @@ -303,7 +303,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct ^ typed_value_to_string ~meta:(Some M.meta) ctx0 v0 ^ "\n- value1: " ^ typed_value_to_string ~meta:(Some M.meta) ctx1 v1)); - craise M.meta "Unexpected match case" + craise __FILE__ __LINE__ M.meta "Unexpected match case" and match_typed_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) (v0 : typed_avalue) (v1 : typed_avalue) : typed_avalue = @@ -357,7 +357,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct M.match_amut_borrows ctx0 ctx1 v0.ty bid0 av0 v1.ty bid1 av1 ty av | AIgnoredMutBorrow _, AIgnoredMutBorrow _ -> (* The abstractions are destructured: we shouldn't get there *) - craise M.meta "Unexpected" + craise __FILE__ __LINE__ M.meta "Unexpected" | AProjSharedBorrow asb0, AProjSharedBorrow asb1 -> ( match (asb0, asb1) with | [], [] -> @@ -366,7 +366,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct v0 | _ -> (* We should get there only if there are nested borrows *) - craise M.meta "Unexpected") + craise __FILE__ __LINE__ M.meta "Unexpected") | _ -> (* TODO: getting there is not necessarily inconsistent (it may just be because the environments don't match) so we may want @@ -377,7 +377,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct we are *currently* ending it, in which case we need to completely end it before continuing. *) - craise M.meta "Unexpected") + craise __FILE__ __LINE__ M.meta "Unexpected") | ALoan lc0, ALoan lc1 -> ( log#ldebug (lazy "match_typed_avalues: loans"); (* TODO: maybe we should enforce that the ids are always exactly the same - @@ -387,7 +387,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct log#ldebug (lazy "match_typed_avalues: shared loans"); let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in - sanity_check (not (value_has_borrows sv.value)) M.meta; + sanity_check __FILE__ __LINE__ (not (value_has_borrows sv.value)) M.meta; M.match_ashared_loans ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 av1 ty sv av | AMutLoan (id0, av0), AMutLoan (id1, av1) -> @@ -402,12 +402,12 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | AIgnoredSharedLoan _, AIgnoredSharedLoan _ -> (* Those should have been filtered when destructuring the abstractions - they are necessary only when there are nested borrows *) - craise M.meta "Unreachable" - | _ -> craise M.meta "Unreachable") + craise __FILE__ __LINE__ M.meta "Unreachable" + | _ -> craise __FILE__ __LINE__ M.meta "Unreachable") | ASymbolic _, ASymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - craise M.meta "Unreachable" + craise __FILE__ __LINE__ M.meta "Unreachable" | _ -> M.match_avalues ctx0 ctx1 v0 v1 end @@ -419,13 +419,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let push_absl (absl : abs list) : unit = List.iter push_abs absl let match_etys _ _ ty0 ty1 = - sanity_check (ty0 = ty1) meta; + sanity_check __FILE__ __LINE__ (ty0 = ty1) meta; ty0 let match_rtys _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) - sanity_check (ty0 = ty1) meta; + sanity_check __FILE__ __LINE__ (ty0 = ty1) meta; ty0 let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) @@ -439,7 +439,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct updates *) let check_no_borrows ctx (v : typed_value) = - sanity_check (not (value_has_borrows ctx v.value)) meta + sanity_check __FILE__ __LINE__ (not (value_has_borrows ctx v.value)) meta in List.iter (check_no_borrows ctx0) adt0.field_values; List.iter (check_no_borrows ctx1) adt1.field_values; @@ -574,12 +574,12 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct do so, we won't introduce reborrows like above: the forward loop function will update [v], while the backward loop function will return nothing. *) - cassert + cassert __FILE__ __LINE__ (not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) meta "Nested borrows are not supported yet"; if bv0 = bv1 then ( - sanity_check (bv0 = bv) meta; + sanity_check __FILE__ __LINE__ (bv0 = bv) meta; (bid0, bv)) else let rid = fresh_region_id () in @@ -587,7 +587,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let kind = RMut in let bv_ty = bv.ty in - sanity_check (ty_no_regions bv_ty) meta; + sanity_check __FILE__ __LINE__ (ty_no_regions bv_ty) meta; let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in let borrow_av = @@ -640,7 +640,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = let bv_ty = bv.ty in - cassert (ty_no_regions bv_ty) meta + cassert __FILE__ __LINE__ (ty_no_regions bv_ty) meta "Nested borrows are not supported yet"; let value = ABorrow (AMutBorrow (bid, mk_aignored meta bv_ty)) in { value; ty = borrow_ty } @@ -688,7 +688,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct raise (ValueMatchFailure (LoansInRight extra_ids_right)); (* This should always be true if we get here *) - sanity_check (ids0 = ids1) meta; + sanity_check __FILE__ __LINE__ (ids0 = ids1) meta; let ids = ids0 in (* Return *) @@ -708,13 +708,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let id1 = sv1.sv_id in if id0 = id1 then ( (* Sanity check *) - sanity_check (sv0 = sv1) meta; + sanity_check __FILE__ __LINE__ (sv0 = sv1) meta; (* Return *) sv0) else ( (* The caller should have checked that the symbolic values don't contain borrows *) - sanity_check + sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)) meta; (* We simply introduce a fresh symbolic value *) @@ -728,14 +728,14 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct If there are loans in the regular value, raise an exception. *) let type_infos = ctx0.type_ctx.type_infos in - cassert + cassert __FILE__ __LINE__ (not (ty_has_borrows type_infos sv.sv_ty)) meta "Check that:\n\ \ - there are no borrows in the symbolic value\n\ \ - there are no borrows in the \"regular\" value\n\ \ If there are loans in the regular value, raise an exception."; - cassert + cassert __FILE__ __LINE__ (not (ValuesUtils.value_has_borrows type_infos v.value)) meta "Check that:\n\ @@ -767,7 +767,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct with | Some (BorrowContent _) -> (* Can't get there: we only ask for outer *loans* *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Some (LoanContent lc) -> ( match lc with | VSharedLoan (ids, _) -> @@ -795,12 +795,12 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) - let match_distinct_aadts _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_borrows _ _ _ _ _ _ = craise meta "Unreachable" - let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_avalues _ _ _ _ = craise meta "Unreachable" + let match_distinct_aadts _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_ashared_borrows _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_avalues _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" end (* Very annoying: functors only take modules as inputs... *) @@ -837,13 +837,13 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct let push_moved_value (v : typed_value) : unit = S.nvalues := v :: !S.nvalues let match_etys _ _ ty0 ty1 = - sanity_check (ty0 = ty1) meta; + sanity_check __FILE__ __LINE__ (ty0 = ty1) meta; ty0 let match_rtys _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) - sanity_check (ty0 = ty1) meta; + sanity_check __FILE__ __LINE__ (ty0 = ty1) meta; ty0 let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) @@ -897,10 +897,10 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct with | Some (BorrowContent _) -> (* Can't get there: we only ask for outer *loans* *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Some (LoanContent _) -> (* We should have ended all the outer loans *) - craise meta "Unexpected outer loan" + craise __FILE__ __LINE__ meta "Unexpected outer loan" | None -> (* Move the value - note that we shouldn't get there if we were not allowed to move the value in the first place. *) @@ -912,17 +912,17 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct fixed-point) has a non-bottom value, while the target environment (e.g., the environment we have when we reach the continue) has bottom: we shouldn't get there. *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) - let match_distinct_aadts _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_borrows _ _ _ _ _ _ = craise meta "Unreachable" - let match_amut_borrows _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_avalues _ _ _ _ = craise meta "Unreachable" + let match_distinct_aadts _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_ashared_borrows _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_amut_borrows _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_avalues _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" end module MakeCheckEquivMatcher (S : MatchCheckEquivState) : CheckEquivMatcher = @@ -1107,7 +1107,7 @@ struct sv else ( (* Check: fixed values are fixed *) - sanity_check + sanity_check __FILE__ __LINE__ (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)) meta; @@ -1126,10 +1126,10 @@ struct (sv : symbolic_value) (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( - sanity_check left meta; + sanity_check __FILE__ __LINE__ left meta; let id = sv.sv_id in (* Check: fixed values are fixed *) - sanity_check (not (SymbolicValueId.InjSubst.mem id !S.sid_map)) meta; + sanity_check __FILE__ __LINE__ (not (SymbolicValueId.InjSubst.mem id !S.sid_map)) meta; (* Update the binding for the target symbolic value *) S.sid_to_value_map := SymbolicValueId.Map.add_strict id v !S.sid_to_value_map; @@ -1351,18 +1351,18 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) be the same and their values equal (and the borrows/loans/symbolic *) if DummyVarId.Set.mem b0 fixed_ids.dids then ((* Fixed values: the values must be equal *) - sanity_check (b0 = b1) meta; - sanity_check (v0 = v1) meta; + sanity_check __FILE__ __LINE__ (b0 = b1) meta; + sanity_check __FILE__ __LINE__ (v0 = v1) meta; (* The ids present in the left value must be fixed *) let ids, _ = compute_typed_value_ids v0 in - sanity_check ((not S.check_equiv) || ids_are_fixed ids)) + sanity_check __FILE__ __LINE__ ((not S.check_equiv) || ids_are_fixed ids)) meta; (* We still match the values - allows to compute mappings (which are the identity actually) *) let _ = M.match_typed_values ctx0 ctx1 v0 v1 in match_envs env0' env1' | EBinding (BVar b0, v0) :: env0', EBinding (BVar b1, v1) :: env1' -> - sanity_check (b0 = b1) meta; + sanity_check __FILE__ __LINE__ (b0 = b1) meta; (* Match the values *) let _ = M.match_typed_values ctx0 ctx1 v0 v1 in (* Continue *) @@ -1373,10 +1373,10 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( log#ldebug (lazy "match_ctxs: match_envs: matching abs: fixed abs"); (* Still in the prefix: the abstractions must be the same *) - sanity_check (abs0 = abs1) meta; + sanity_check __FILE__ __LINE__ (abs0 = abs1) meta; (* Their ids must be fixed *) let ids, _ = compute_abs_ids abs0 in - sanity_check ((not S.check_equiv) || ids_are_fixed ids) meta; + sanity_check __FILE__ __LINE__ ((not S.check_equiv) || ids_are_fixed ids) meta; (* Continue *) match_envs env0' env1') else ( @@ -1404,7 +1404,7 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) let env0, env1 = match (env0, env1) with | EFrame :: env0, EFrame :: env1 -> (env0, env1) - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in match_envs env0 env1; @@ -1427,7 +1427,7 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) let ctxs_are_equivalent (meta : Meta.meta) (fixed_ids : ids_sets) (ctx0 : eval_ctx) (ctx1 : eval_ctx) : bool = let check_equivalent = true in - let lookup_shared_value _ = craise meta "Unreachable" in + let lookup_shared_value _ = craise __FILE__ __LINE__ meta "Unreachable" in Option.is_some (match_ctxs meta check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx0 ctx1) @@ -1482,14 +1482,14 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (fun (var0, var1) -> match (var0, var1) with | EBinding (BDummy b0, v0), EBinding (BDummy b1, v1) -> - sanity_check (b0 = b1) meta; + sanity_check __FILE__ __LINE__ (b0 = b1) meta; let _ = M.match_typed_values src_ctx tgt_ctx v0 v1 in () | EBinding (BVar b0, v0), EBinding (BVar b1, v1) -> - sanity_check (b0 = b1) meta; + sanity_check __FILE__ __LINE__ (b0 = b1) meta; let _ = M.match_typed_values src_ctx tgt_ctx v0 v1 in () - | _ -> craise meta "Unexpected") + | _ -> craise __FILE__ __LINE__ meta "Unexpected") (List.combine filt_src_env filt_tgt_env) in (* No exception was thrown: continue *) @@ -1520,14 +1520,14 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (fun (var0, var1) -> match (var0, var1) with | EBinding (BDummy b0, v0), EBinding ((BDummy b1 as var1), v1) -> - sanity_check (b0 = b1) meta; + sanity_check __FILE__ __LINE__ (b0 = b1) meta; let v = M.match_typed_values src_ctx tgt_ctx v0 v1 in (var1, v) | EBinding (BVar b0, v0), EBinding ((BVar b1 as var1), v1) -> - sanity_check (b0 = b1) meta; + sanity_check __FILE__ __LINE__ (b0 = b1) meta; let v = M.match_typed_values src_ctx tgt_ctx v0 v1 in (var1, v) - | _ -> craise meta "Unexpected") + | _ -> craise __FILE__ __LINE__ meta "Unexpected") (List.combine filt_src_env filt_tgt_env) in let var_to_new_val = BinderMap.of_list var_to_new_val in @@ -1567,7 +1567,7 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) | LoanInRight bid -> InterpreterBorrows.end_borrow config meta bid | LoansInRight bids -> InterpreterBorrows.end_borrows config meta bids | AbsInRight _ | AbsInLeft _ | LoanInLeft _ | LoansInLeft _ -> - craise meta "Unexpected" + craise __FILE__ __LINE__ meta "Unexpected" in comp cc cf_reorganize_join_tgt cf tgt_ctx in @@ -1627,7 +1627,7 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) let filt_src_env, new_absl, new_dummyl = ctx_split_fixed_new meta fixed_ids src_ctx in - sanity_check (new_dummyl = []) meta; + sanity_check __FILE__ __LINE__ (new_dummyl = []) meta; let filt_tgt_ctx = { tgt_ctx with env = filt_tgt_env } in let filt_src_ctx = { src_ctx with env = filt_src_env } in @@ -1639,7 +1639,7 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) match snd (lookup_loan meta ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let lookup_in_src id = lookup_shared_loan id src_ctx in let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in @@ -1765,7 +1765,7 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) abstractions and in the *variable bindings* once we allow symbolic values containing borrows to not be eagerly expanded. *) - sanity_check Config.greedy_expand_symbolics_with_borrows meta; + sanity_check __FILE__ __LINE__ Config.greedy_expand_symbolics_with_borrows meta; (* Update the borrows and loans in the abstractions of the target context. @@ -1834,7 +1834,7 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) (* No mapping: this means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) and because of this, it should actually be mapped to itself *) - sanity_check + sanity_check __FILE__ __LINE__ (BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id) meta; id @@ -1848,8 +1848,8 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) method! visit_abs env abs = match abs.kind with | Loop (loop_id', rg_id, kind) -> - sanity_check (loop_id' = loop_id) meta; - sanity_check (kind = LoopSynthInput) meta; + sanity_check __FILE__ __LINE__ (loop_id' = loop_id) meta; + sanity_check __FILE__ __LINE__ (kind = LoopSynthInput) meta; let can_end = false in let kind : abs_kind = Loop (loop_id, rg_id, LoopCall) in let abs = { abs with kind; can_end } in diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index c386c2db..26456acf 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -87,7 +87,7 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (lazy ("Not the same type:\n- nv.ty: " ^ show_ety nv.ty ^ "\n- v.ty: " ^ show_ety v.ty)); - craise meta + craise __FILE__ __LINE__ meta "Assertion failed: new value doesn't have the same type as its \ destination"); Ok (ctx, { read = v; updated = nv }) @@ -100,9 +100,9 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (* Check consistency *) (match (proj_kind, type_id) with | ProjAdt (def_id, opt_variant_id), TAdtId def_id' -> - sanity_check (def_id = def_id') meta; - sanity_check (opt_variant_id = adt.variant_id) meta - | _ -> craise meta "Unreachable"); + sanity_check __FILE__ __LINE__ (def_id = def_id') meta; + sanity_check __FILE__ __LINE__ (opt_variant_id = adt.variant_id) meta + | _ -> craise __FILE__ __LINE__ meta "Unreachable"); (* Actually project *) let fv = FieldId.nth adt.field_values field_id in match access_projection meta access ctx update p' fv with @@ -117,7 +117,7 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) Ok (ctx, { res with updated })) (* Tuples *) | Field (ProjTuple arity, field_id), VAdt adt, TAdt (TTuple, _) -> ( - sanity_check (arity = List.length adt.field_values) meta; + sanity_check __FILE__ __LINE__ (arity = List.length adt.field_values) meta; let fv = FieldId.nth adt.field_values field_id in (* Project *) match access_projection meta access ctx update p' fv with @@ -166,7 +166,7 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) if access.lookup_shared_borrows then match lookup_loan meta ek bid ctx with | _, Concrete (VMutLoan _) -> - craise meta "Expected a shared loan" + craise __FILE__ __LINE__ meta "Expected a shared loan" | _, Concrete (VSharedLoan (bids, sv)) -> ( (* Explore the shared value *) match access_projection meta access ctx update p' sv with @@ -191,7 +191,7 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } | AIgnoredSharedLoan _ ) ) -> - craise meta "Expected a shared (abstraction) loan" + craise __FILE__ __LINE__ meta "Expected a shared (abstraction) loan" | _, Abstract (ASharedLoan (bids, sv, _av)) -> ( (* Explore the shared value *) match access_projection meta access ctx update p' sv with @@ -201,7 +201,7 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) let av = match lookup_loan meta ek bid ctx with | _, Abstract (ASharedLoan (_, _, av)) -> av - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in (* Update the shared loan with the new value returned by {!access_projection} *) @@ -248,7 +248,7 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) let v = "- v:\n" ^ show_value v in let ty = "- ty:\n" ^ show_ety ty in log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); - craise meta "Inconsistent projection") + craise __FILE__ __LINE__ meta "Inconsistent projection") (** Generic function to access (read/write) the value at a given place. @@ -321,13 +321,13 @@ let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) ^ show_env ctx1.env ^ "\n\nOld environment:\n" ^ show_env ctx.env in log#serror msg; - craise meta "Unexpected environment update"); + craise __FILE__ __LINE__ meta "Unexpected environment update"); Ok read_value let read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value = match try_read_place meta access p ctx with - | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) + | Error e -> craise __FILE__ __LINE__ meta ("Unreachable: " ^ show_path_fail_kind e) | Ok v -> v (** Attempt to update the value at a given place *) @@ -345,19 +345,19 @@ let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) let write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : typed_value) (ctx : eval_ctx) : eval_ctx = match try_write_place meta access p nv ctx with - | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) + | Error e -> craise __FILE__ __LINE__ meta ("Unreachable: " ^ show_path_fail_kind e) | Ok ctx -> ctx let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) (generics : generic_args) : typed_value = - sanity_check (TypesUtils.generic_args_only_erased_regions generics) meta; + sanity_check __FILE__ __LINE__ (TypesUtils.generic_args_only_erased_regions generics) meta; (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) let def = ctx_lookup_type_decl ctx def_id in - sanity_check + sanity_check __FILE__ __LINE__ (List.length generics.regions = List.length def.generics.regions) meta; (* Compute the field types *) @@ -430,7 +430,7 @@ let expand_bottom_value_from_projection (meta : Meta.meta) (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), TAdt (TAdtId def_id', generics) ) -> - sanity_check (def_id = def_id') meta; + sanity_check __FILE__ __LINE__ (def_id = def_id') meta; compute_expanded_bottom_adt_value meta ctx def_id opt_variant_id generics (* Tuples *) @@ -438,17 +438,17 @@ let expand_bottom_value_from_projection (meta : Meta.meta) TAdt (TTuple, { regions = []; types; const_generics = []; trait_refs = [] }) ) -> - sanity_check (arity = List.length types) meta; + sanity_check __FILE__ __LINE__ (arity = List.length types) meta; (* Generate the field values *) compute_expanded_bottom_tuple_value meta types | _ -> - craise meta + craise __FILE__ __LINE__ meta ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty) in (* Update the context by inserting the expanded value at the proper place *) match try_write_place meta access p' nv ctx with | Ok ctx -> ctx - | Error _ -> craise meta "Unreachable" + | Error _ -> craise __FILE__ __LINE__ meta "Unreachable" let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (access : access_kind) (p : place) : cm_fun = @@ -474,8 +474,8 @@ let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (Some (Synth.mk_mplace meta prefix ctx)) | FailBottom (_, _, _) -> (* We can't expand {!Bottom} values while reading them *) - craise meta "Found [Bottom] while reading a place" - | FailBorrow _ -> craise meta "Could not read a borrow" + craise __FILE__ __LINE__ meta "Found [Bottom] while reading a place" + | FailBorrow _ -> craise __FILE__ __LINE__ meta "Could not read a borrow" in comp cc (update_ctx_along_read_place config meta access p) cf ctx @@ -506,7 +506,7 @@ let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) pe ty ctx in cf ctx - | FailBorrow _ -> craise meta "Could not write to a borrow" + | FailBorrow _ -> craise __FILE__ __LINE__ meta "Could not write to a borrow" in (* Retry *) comp cc (update_ctx_along_write_place config meta access p) cf ctx @@ -596,7 +596,7 @@ let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) match c with | LoanContent (VSharedLoan (bids, _)) -> end_borrows config meta bids | LoanContent (VMutLoan bid) -> end_borrow config meta bid - | BorrowContent _ -> craise meta "Unreachable" + | BorrowContent _ -> craise __FILE__ __LINE__ meta "Unreachable" in (* Retry *) comp cc drop cf ctx @@ -611,7 +611,7 @@ let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) (* Reinsert *) let ctx = write_place meta access p v ctx in (* Sanity check *) - sanity_check (not (outer_loans_in_value v)) meta; + sanity_check __FILE__ __LINE__ (not (outer_loans_in_value v)) meta; (* Continue *) cf ctx) in @@ -636,7 +636,7 @@ let prepare_lplace (config : config) (meta : Meta.meta) (p : place) fun ctx -> let v = read_place meta access p ctx in (* Sanity checks *) - sanity_check (not (outer_loans_in_value v)) meta; + sanity_check __FILE__ __LINE__ (not (outer_loans_in_value v)) meta; (* Continue *) cf v ctx in diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index f8f99584..0421a46c 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -18,7 +18,7 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) (* Sanity check - TODO: move those elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Subst.erase_regions ty in - sanity_check (ty_is_rty ty && ety = v.ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty ty && ety = v.ty) meta; (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then [] else @@ -41,7 +41,7 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) fields_types in List.concat proj_fields - | VBottom, _ -> craise meta "Unreachable" + | VBottom, _ -> craise __FILE__ __LINE__ meta "Unreachable" | VBorrow bc, TRef (r, ref_ty, kind) -> (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) let bid, asb = @@ -64,13 +64,13 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | _, Abstract (ASharedLoan (_, sv, _)) -> apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions sv ref_ty - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in (bid, asb) | VReservedMutBorrow _, _ -> - craise meta + craise __FILE__ __LINE__ meta "Can't apply a proj_borrow over a reserved mutable borrow" - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let asb = (* Check if the region is in the set of projected regions (note that @@ -81,15 +81,15 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) else asb in asb - | VLoan _, _ -> craise meta "Unreachable" + | VLoan _, _ -> craise __FILE__ __LINE__ meta "Unreachable" | VSymbolic s, _ -> (* Check that the projection doesn't contain ended regions *) - sanity_check + sanity_check __FILE__ __LINE__ (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) meta; [ AsbProjReborrows (s, ty) ] - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) (ctx : eval_ctx) (fresh_reborrow : BorrowId.id -> BorrowId.id) @@ -98,7 +98,7 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Substitute.erase_regions ty in - sanity_check (ty_is_rty ty && ety = v.ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty ty && ety = v.ty) meta; (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then { value = AIgnored; ty } else @@ -121,7 +121,7 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) fields_types in AAdt { variant_id = adt.variant_id; field_values = proj_fields } - | VBottom, _ -> craise meta "Unreachable" + | VBottom, _ -> craise __FILE__ __LINE__ meta "Unreachable" | VBorrow bc, TRef (r, ref_ty, kind) -> if (* Check if the region is in the set of projected regions (note that @@ -152,9 +152,9 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) *) ASharedBorrow bid | VReservedMutBorrow _, _ -> - craise meta + craise __FILE__ __LINE__ meta "Can't apply a proj_borrow over a reserved mutable borrow" - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in ABorrow bc else @@ -186,16 +186,16 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) | _, Abstract (ASharedLoan (_, sv, _)) -> apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions sv ref_ty - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" in AProjSharedBorrow asb | VReservedMutBorrow _, _ -> - craise meta + craise __FILE__ __LINE__ meta "Can't apply a proj_borrow over a reserved mutable borrow" - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in ABorrow bc - | VLoan _, _ -> craise meta "Unreachable" + | VLoan _, _ -> craise __FILE__ __LINE__ meta "Unreachable" | VSymbolic s, _ -> (* Check that the projection doesn't contain already ended regions, * if necessary *) @@ -212,7 +212,7 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " ^ RegionId.Set.to_string None rset2 ^ "\n")); - sanity_check (not (projections_intersect meta ty1 rset1 ty2 rset2))) + sanity_check __FILE__ __LINE__ (not (projections_intersect meta ty1 rset1 ty2 rset2))) meta; ASymbolic (AProjBorrows (s, ty)) | _ -> @@ -221,7 +221,7 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ("apply_proj_borrows: unexpected inputs:\n- input value: " ^ typed_value_to_string ~meta:(Some meta) ctx v ^ "\n- proj rty: " ^ ty_to_string ctx ty)); - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in { value; ty } @@ -237,7 +237,7 @@ let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) in VAdt { variant_id; field_values } | SeMutRef (_, _) | SeSharedRef (_, _) -> - craise meta "Unexpected symbolic reference expansion" + craise __FILE__ __LINE__ meta "Unexpected symbolic reference expansion" in { value; ty } @@ -250,7 +250,7 @@ let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) let value = VBorrow (VMutBorrow (bid, bv)) in { value; ty } | SeSharedRef (_, _) -> - craise meta "Unexpected symbolic shared reference expansion" + craise __FILE__ __LINE__ meta "Unexpected symbolic shared reference expansion" | _ -> symbolic_expansion_non_borrow_to_value meta sv see (** Apply (and reduce) a projector over loans to a value. @@ -262,7 +262,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (see : symbolic_expansion) (original_sv_ty : rty) : typed_avalue = (* Sanity check: if we have a proj_loans over a symbolic value, it should * contain regions which we will project *) - sanity_check (ty_has_regions_in_set regions original_sv_ty) meta; + sanity_check __FILE__ __LINE__ (ty_has_regions_in_set regions original_sv_ty) meta; (* Match *) let (value, ty) : avalue * ty = match (see, original_sv_ty) with @@ -277,7 +277,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (AAdt { variant_id; field_values }, original_sv_ty) | SeMutRef (bid, spc), TRef (r, ref_ty, RMut) -> (* Sanity check *) - sanity_check (spc.sv_ty = ref_ty) meta; + sanity_check __FILE__ __LINE__ (spc.sv_ty = ref_ty) meta; (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in (* Check if the region is in the set of projected regions (note that @@ -295,7 +295,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (ALoan (AIgnoredMutLoan (opt_bid, child_av)), ref_ty) | SeSharedRef (bids, spc), TRef (r, ref_ty, RShared) -> (* Sanity check *) - sanity_check (spc.sv_ty = ref_ty) meta; + sanity_check __FILE__ __LINE__ (spc.sv_ty = ref_ty) meta; (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in (* Check if the region is in the set of projected regions (note that @@ -307,7 +307,7 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) else (* Not in the set: ignore *) (ALoan (AIgnoredSharedLoan child_av), ref_ty) - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in { value; ty } @@ -465,7 +465,7 @@ let apply_reborrows (meta : Meta.meta) (* Visit *) let ctx = obj#visit_eval_ctx () ctx in (* Check that there are no reborrows remaining *) - sanity_check (!reborrows = []) meta; + sanity_check __FILE__ __LINE__ (!reborrows = []) meta; (* Return *) ctx @@ -479,13 +479,13 @@ let prepare_reborrows (config : config) (meta : Meta.meta) let bid' = fresh_borrow_id () in reborrows := (bid, bid') :: !reborrows; bid') - else craise meta "Unexpected reborrow" + else craise __FILE__ __LINE__ meta "Unexpected reborrow" in (* The function to apply the reborrows in a context *) let apply_registered_reborrows (ctx : eval_ctx) : eval_ctx = match config.mode with | ConcreteMode -> - sanity_check (!reborrows = []) meta; + sanity_check __FILE__ __LINE__ (!reborrows = []) meta; ctx | SymbolicMode -> (* Apply the reborrows *) @@ -498,7 +498,7 @@ let apply_proj_borrows_on_input_value (config : config) (meta : Meta.meta) (ctx : eval_ctx) (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = - cassert (ty_is_rty ty) meta "TODO: error message"; + cassert __FILE__ __LINE__ (ty_is_rty ty) meta "TODO: error message"; let check_symbolic_no_ended = true in let allow_reborrows = true in (* Prepare the reborrows *) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index fa7bbc51..ccf8a5ac 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -121,7 +121,7 @@ let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) let ctx = ctx_push_dummy_var ctx dest_vid mv in (* Write to the destination *) (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) - exec_assert + exec_assert __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions rv)) meta "The value to move contains bottom"; (* Update the destination *) @@ -152,7 +152,7 @@ let eval_assertion_concrete (config : config) (meta : Meta.meta) (* Branch *) if b = assertion.expected then cf Unit ctx else cf Panic ctx | _ -> - craise meta + craise __FILE__ __LINE__ meta ("Expected a boolean, got: " ^ typed_value_to_string ~meta:(Some meta) ctx v) in @@ -173,7 +173,7 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) (* Evaluate the assertion *) let eval_assert cf (v : typed_value) : m_fun = fun ctx -> - sanity_check (v.ty = TLiteral TBool) meta; + sanity_check __FILE__ __LINE__ (v.ty = TLiteral TBool) meta; (* We make a choice here: we could completely decouple the concrete and * symbolic executions here but choose not to. In the case where we * know the concrete value of the boolean we test, we use this value @@ -184,8 +184,8 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) (* Delegate to the concrete evaluation function *) eval_assertion_concrete config meta assertion cf ctx | VSymbolic sv -> - sanity_check (config.mode = SymbolicMode) meta; - sanity_check (sv.sv_ty = TLiteral TBool) meta; + sanity_check __FILE__ __LINE__ (config.mode = SymbolicMode) meta; + sanity_check __FILE__ __LINE__ (sv.sv_ty = TLiteral TBool) meta; (* We continue the execution as if the test had succeeded, and thus * perform the symbolic expansion: sv ~~> true. * We will of course synthesize an assertion in the generated code @@ -199,7 +199,7 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) (* Add the synthesized assertion *) S.synthesize_assertion ctx v expr | _ -> - craise meta + craise __FILE__ __LINE__ meta ("Expected a boolean, got: " ^ typed_value_to_string ~meta:(Some meta) ctx v) in @@ -243,7 +243,7 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) a variant with all its fields set to {!Bottom} *) match av.variant_id with - | None -> craise meta "Found a struct value while expected an enum" + | None -> craise __FILE__ __LINE__ meta "Found a struct value while expected an enum" | Some variant_id' -> if variant_id' = variant_id then (* Nothing to do *) cf Unit ctx @@ -254,7 +254,7 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) | TAdtId def_id -> compute_expanded_bottom_adt_value meta ctx def_id (Some variant_id) generics - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in assign_to_place config meta bottom_v p (cf Unit) ctx) | TAdt ((TAdtId _ as type_id), generics), VBottom -> @@ -263,11 +263,11 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) | TAdtId def_id -> compute_expanded_bottom_adt_value meta ctx def_id (Some variant_id) generics - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in assign_to_place config meta bottom_v p (cf Unit) ctx | _, VSymbolic _ -> - sanity_check (config.mode = SymbolicMode) meta; + sanity_check __FILE__ __LINE__ (config.mode = SymbolicMode) meta; (* This is a bit annoying: in theory we should expand the symbolic value * then set the discriminant, because in the case the discriminant is * exactly the one we set, the fields are left untouched, and in the @@ -275,9 +275,9 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) * For now, we forbid setting the discriminant of a symbolic value: * setting a discriminant should only be used to initialize a value, * or reset an already initialized value, really. *) - craise meta "Unexpected value" - | _, (VAdt _ | VBottom) -> craise meta "Inconsistent state" - | _, (VLiteral _ | VBorrow _ | VLoan _) -> craise meta "Unexpected value" + craise __FILE__ __LINE__ meta "Unexpected value" + | _, (VAdt _ | VBottom) -> craise __FILE__ __LINE__ meta "Inconsistent state" + | _, (VLiteral _ | VBorrow _ | VLoan _) -> craise __FILE__ __LINE__ meta "Unexpected value" in (* Compose and apply *) comp cc update_value cf ctx @@ -294,13 +294,13 @@ let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) *) let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : assumed_fun_id) (generics : generic_args) : ety = - sanity_check (generics.trait_refs = []) meta; + sanity_check __FILE__ __LINE__ (generics.trait_refs = []) meta; (* [Box::free] has a special treatment *) match fid with | BoxFree -> - sanity_check (generics.regions = []) meta; - sanity_check (List.length generics.types = 1) meta; - sanity_check (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (generics.regions = []) meta; + sanity_check __FILE__ __LINE__ (List.length generics.types = 1) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; mk_unit_ty | _ -> (* Retrieve the function's signature *) @@ -337,7 +337,7 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) let ret_vid = VarId.zero in let rec list_locals env = match env with - | [] -> craise meta "Inconsistent environment" + | [] -> craise __FILE__ __LINE__ meta "Inconsistent environment" | EAbs _ :: env -> list_locals env | EBinding (BDummy _, _) :: env -> list_locals env | EBinding (BVar var, _) :: env -> @@ -361,7 +361,7 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) match ret_value with | None -> () | Some ret_value -> - sanity_check + sanity_check __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions ret_value)) meta) in @@ -394,7 +394,7 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) * no outer loans) as dummy variables in the caller frame *) let rec pop env = match env with - | [] -> craise meta "Inconsistent environment" + | [] -> craise __FILE__ __LINE__ meta "Inconsistent environment" | EAbs abs :: env -> EAbs abs :: pop env | EBinding (_, v) :: env -> let vid = fresh_dummy_var_id () in @@ -434,7 +434,7 @@ let eval_box_new_concrete (config : config) (meta : Meta.meta) :: EBinding (_ret_var, _) :: EFrame :: _ ) -> (* Required type checking *) - cassert (input_value.ty = boxed_ty) meta "TODO: Error message"; + cassert __FILE__ __LINE__ (input_value.ty = boxed_ty) meta "TODO: Error message"; (* Move the input value *) let cf_move = @@ -461,7 +461,7 @@ let eval_box_new_concrete (config : config) (meta : Meta.meta) (* Compose and apply *) comp cf_move cf_create cf ctx - | _ -> craise meta "Inconsistent state" + | _ -> craise __FILE__ __LINE__ meta "Inconsistent state" (** Auxiliary function - see {!eval_assumed_function_call}. @@ -492,7 +492,7 @@ let eval_box_free (config : config) (meta : Meta.meta) (generics : generic_args) InterpreterPaths.read_place meta Write input_box_place ctx in (let input_ty = ty_get_box input_box.ty in - sanity_check (input_ty = boxed_ty)) + sanity_check __FILE__ __LINE__ (input_ty = boxed_ty)) meta; (* Drop the value *) @@ -503,7 +503,7 @@ let eval_box_free (config : config) (meta : Meta.meta) (generics : generic_args) (* Continue *) cc cf ctx - | _ -> craise meta "Inconsistent state" + | _ -> craise __FILE__ __LINE__ meta "Inconsistent state" (** Evaluate a non-local function call in concrete mode *) let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) @@ -513,12 +513,12 @@ let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) match call.func with | FnOpMove _ -> (* Closure case: TODO *) - craise meta "Closures are not supported yet" + craise __FILE__ __LINE__ meta "Closures are not supported yet" | FnOpRegular func -> ( let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - sanity_check (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -571,11 +571,11 @@ let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) | BoxNew -> eval_box_new_concrete config meta generics | BoxFree -> (* Should have been treated above *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut -> - craise meta "Unimplemented" + craise __FILE__ __LINE__ meta "Unimplemented" in let cc = comp cc cf_eval_body in @@ -755,7 +755,7 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) match call.func with | FnOpMove _ -> (* Closure case: TODO *) - craise meta "Closures are not supported yet" + craise __FILE__ __LINE__ meta "Closures are not supported yet" | FnOpRegular func -> ( match func.func with | FunId (FRegular fid) -> @@ -779,7 +779,7 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (func.func, func.generics, None, def, regions_hierarchy, inst_sg) | FunId (FAssumed _) -> (* Unreachable: must be a transparent function *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | TraitMethod (trait_ref, method_name, _) -> ( log#ldebug (lazy @@ -839,7 +839,7 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) | None -> (* If not found, lookup the methods provided by the trait *declaration* (remember: for now, we forbid overriding provided methods) *) - cassert + cassert __FILE__ __LINE__ (trait_impl.provided_methods = []) meta "Overriding provided methods is currently forbidden"; let trait_decl = @@ -996,7 +996,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = * also it can lead to issues - for instance, if we borrow a * reserved borrow, we later can't translate it to pure values...) *) match rvalue with - | Global _ -> craise st.meta "Unreachable" + | Global _ -> craise __FILE__ __LINE__ st.meta "Unreachable" | Use _ | RvRef (_, (BShared | BMut | BTwoPhaseMut | BShallow)) | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> @@ -1063,7 +1063,7 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) - cassert (ty_no_regions global.ty) global.meta + cassert __FILE__ __LINE__ (ty_no_regions global.ty) global.meta "Const globals should not contain regions"; (* Instantiate the type *) (* There shouldn't be any reference to Self *) @@ -1125,7 +1125,7 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : expand_symbolic_bool config meta sv (S.mk_opt_place_from_op meta op ctx) cf_true cf_false cf ctx - | _ -> craise meta "Inconsistent state" + | _ -> craise __FILE__ __LINE__ meta "Inconsistent state" in (* Compose *) comp cf_eval_op cf_if cf ctx @@ -1140,7 +1140,7 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : (* Evaluate the branch *) let cf_eval_branch cf = (* Sanity check *) - sanity_check (sv.int_ty = int_ty) meta; + sanity_check __FILE__ __LINE__ (sv.int_ty = int_ty) meta; (* Find the branch *) match List.find_opt (fun (svl, _) -> List.mem sv svl) stgts with | None -> eval_statement config otherwise cf @@ -1172,7 +1172,7 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : expand_symbolic_int config meta sv (S.mk_opt_place_from_op meta op ctx) int_ty stgts otherwise cf ctx - | _ -> craise meta "Inconsistent state" + | _ -> craise __FILE__ __LINE__ meta "Inconsistent state" in (* Compose *) comp cf_eval_op cf_switch cf ctx @@ -1199,7 +1199,7 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : match List.find_opt (fun (svl, _) -> List.mem dv svl) stgts with | None -> ( match otherwise with - | None -> craise meta "No otherwise branch" + | None -> craise __FILE__ __LINE__ meta "No otherwise branch" | Some otherwise -> eval_statement config otherwise cf ctx) | Some (_, tgt) -> eval_statement config tgt cf ctx) | VSymbolic sv -> @@ -1211,7 +1211,7 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : (* Re-evaluate the switch - the value is not symbolic anymore, which means we will go to the other branch *) cf_expand (eval_switch config meta switch) cf ctx - | _ -> craise meta "Inconsistent state" + | _ -> craise __FILE__ __LINE__ meta "Inconsistent state" in (* Compose *) comp cf_read_p cf_match cf ctx @@ -1235,7 +1235,7 @@ and eval_function_call_concrete (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = fun cf ctx -> match call.func with - | FnOpMove _ -> craise meta "Closures are not supported yet" + | FnOpMove _ -> craise __FILE__ __LINE__ meta "Closures are not supported yet" | FnOpRegular func -> ( match func.func with | FunId (FRegular fid) -> @@ -1246,12 +1246,12 @@ and eval_function_call_concrete (config : config) (meta : Meta.meta) * where we haven't panicked. Of course, the translation needs to take the * panic case into account... *) eval_assumed_function_call_concrete config meta fid call (cf Unit) ctx - | TraitMethod _ -> craise meta "Unimplemented") + | TraitMethod _ -> craise __FILE__ __LINE__ meta "Unimplemented") and eval_function_call_symbolic (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = match call.func with - | FnOpMove _ -> craise meta "Closures are not supported yet" + | FnOpMove _ -> craise __FILE__ __LINE__ meta "Closures are not supported yet" | FnOpRegular func -> ( match func.func with | FunId (FRegular _) | TraitMethod _ -> @@ -1265,12 +1265,12 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let args = call.args in let dest = call.dest in match call.func with - | FnOpMove _ -> craise meta "Closures are not supported yet" + | FnOpMove _ -> craise __FILE__ __LINE__ meta "Closures are not supported yet" | FnOpRegular func -> let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - sanity_check (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; fun cf ctx -> (* Retrieve the (correctly instantiated) body *) let def = ctx_lookup_fun_decl ctx fid in @@ -1278,13 +1278,13 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let body = match def.body with | None -> - craise meta + craise __FILE__ __LINE__ meta ("Can't evaluate a call to an opaque function: " ^ name_to_string ctx def.name) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) - cassert (generics.trait_refs = []) body.meta + cassert __FILE__ __LINE__ (generics.trait_refs = []) body.meta "Traits are not supported yet in concrete mode"; (* There shouldn't be any reference to Self *) let tr_self = UnknownTrait __FUNCTION__ in @@ -1294,7 +1294,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - sanity_check (List.length args = body.arg_count) body.meta; + sanity_check __FILE__ __LINE__ (List.length args = body.arg_count) body.meta; let cc = eval_operands config body.meta args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result @@ -1307,7 +1307,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let ret_var, locals = match locals with | ret_ty :: locals -> (ret_ty, locals) - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let input_locals, locals = Collections.List.split_at locals body.arg_count @@ -1343,7 +1343,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) pop_frame_assign config meta dest (cf Unit) | Break _ | Continue _ | Unit | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in let cc = comp cc cf_finish in @@ -1358,7 +1358,7 @@ and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) eval_transparent_function_call_symbolic_inst meta call ctx in (* Sanity check *) - sanity_check + sanity_check __FILE__ __LINE__ (List.length call.args = List.length def.signature.inputs) def.meta; (* Evaluate the function call *) @@ -1418,7 +1418,7 @@ and eval_function_call_symbolic_from_inst_sig (config : config) let args_with_rtypes = List.combine args inst_sg.inputs in (* Check the type of the input arguments *) - cassert + cassert __FILE__ __LINE__ (List.for_all (fun ((arg, rty) : typed_value * rty) -> arg.ty = Subst.erase_regions rty) @@ -1428,7 +1428,7 @@ and eval_function_call_symbolic_from_inst_sig (config : config) * be fed to functions (i.e., symbolic values output from function return * values and which contain borrows of borrows can't be used as function * inputs *) - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun arg -> not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) @@ -1536,7 +1536,7 @@ and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) let dest = call.dest in (* Sanity check: make sure the type parameters don't contain regions - * this is a current limitation of our synthesis *) - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun ty -> not (ty_has_borrows ctx.type_ctx.type_infos ty)) generics.types) @@ -1561,7 +1561,7 @@ and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) match fid with | BoxFree -> (* Should have been treated above *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | _ -> let regions_hierarchy = LlbcAstUtils.FunIdMap.find (FAssumed fid) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 9ffab771..4fd7722e 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -21,7 +21,7 @@ let get_cf_ctx_no_synth (meta : Meta.meta) (f : cm_fun) (ctx : eval_ctx) : eval_ctx = let nctx = ref None in let cf ctx = - sanity_check (!nctx = None) meta; + sanity_check __FILE__ __LINE__ (!nctx = None) meta; nctx := Some ctx; None in @@ -85,19 +85,19 @@ let mk_place_from_var_id (var_id : VarId.id) : place = (** Create a fresh symbolic value *) let mk_fresh_symbolic_value (meta : Meta.meta) (ty : ty) : symbolic_value = (* Sanity check *) - sanity_check (ty_is_rty ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty ty) meta; let sv_id = fresh_symbolic_value_id () in let svalue = { sv_id; sv_ty = ty } in svalue let mk_fresh_symbolic_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : symbolic_value = - sanity_check (ty_no_regions ty) meta; + sanity_check __FILE__ __LINE__ (ty_no_regions ty) meta; mk_fresh_symbolic_value meta ty (** Create a fresh symbolic value *) let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = - sanity_check (ty_is_rty rty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty rty) meta; let ty = Substitute.erase_regions rty in (* Generate the fresh a symbolic value *) let value = mk_fresh_symbolic_value meta rty in @@ -106,7 +106,7 @@ let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = let mk_fresh_symbolic_typed_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : typed_value = - sanity_check (ty_no_regions ty) meta; + sanity_check __FILE__ __LINE__ (ty_no_regions ty) meta; mk_fresh_symbolic_typed_value meta ty (** Create a typed value from a symbolic value. *) @@ -136,7 +136,7 @@ let mk_aproj_loans_value_from_symbolic_value (regions : RegionId.Set.t) let mk_aproj_borrows_from_symbolic_value (meta : Meta.meta) (proj_regions : RegionId.Set.t) (svalue : symbolic_value) (proj_ty : ty) : aproj = - sanity_check (ty_is_rty proj_ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty proj_ty) meta; if ty_has_regions_in_set proj_regions proj_ty then AProjBorrows (svalue, proj_ty) else AIgnoredProjBorrows @@ -162,7 +162,7 @@ let remove_borrow_from_asb (meta : Meta.meta) (bid : BorrowId.id) false)) asb in - sanity_check (!removed = 1) meta; + sanity_check __FILE__ __LINE__ (!removed = 1) meta; asb (** We sometimes need to return a value whose type may vary depending on @@ -508,8 +508,8 @@ let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (* Generate the type substitution Note that for now we don't support instantiating the type parameters with types containing regions. *) - sanity_check (List.for_all TypesUtils.ty_no_regions generics.types) meta; - sanity_check (TypesUtils.trait_instance_id_no_regions tr_self) meta; + sanity_check __FILE__ __LINE__ (List.for_all TypesUtils.ty_no_regions generics.types) meta; + sanity_check __FILE__ __LINE__ (TypesUtils.trait_instance_id_no_regions tr_self) meta; let tsubst = Substitute.make_type_subst_from_vars sg.generics.types generics.types in diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 1c10bf7e..830661d2 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -79,12 +79,12 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let infos = !borrows_infos in (* Use the first borrow id as representant *) let repr_bid = BorrowId.Set.min_elt bids in - sanity_check (not (BorrowId.Map.mem repr_bid infos)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem repr_bid infos)) meta; (* Insert the mappings to the representant *) let reprs = BorrowId.Set.fold (fun bid reprs -> - sanity_check (not (BorrowId.Map.mem bid reprs)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem bid reprs)) meta; BorrowId.Map.add bid repr_bid reprs) bids reprs in @@ -107,8 +107,8 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let reprs = !ids_reprs in let infos = !borrows_infos in (* Sanity checks *) - sanity_check (not (BorrowId.Map.mem bid reprs)) meta; - sanity_check (not (BorrowId.Map.mem bid infos)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem bid reprs)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem bid infos)) meta; (* Add the mapping for the representant *) let reprs = BorrowId.Map.add bid bid reprs in (* Add the mapping for the loan info *) @@ -186,7 +186,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : ^ BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () in log#serror err; - craise meta err + craise __FILE__ __LINE__ meta err in let update_info (bid : BorrowId.id) (info : borrow_info) : unit = @@ -196,7 +196,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let infos = BorrowId.Map.update repr_bid (fun x -> - match x with Some _ -> Some info | None -> craise meta "Unreachable") + match x with Some _ -> Some info | None -> craise __FILE__ __LINE__ meta "Unreachable") !borrows_infos in borrows_infos := infos @@ -210,12 +210,12 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : (* Check that the borrow kind is consistent *) (match (info.loan_kind, kind) with | RShared, (BShared | BReserved) | RMut, BMut -> () - | _ -> craise meta "Invariant not satisfied"); + | _ -> craise __FILE__ __LINE__ meta "Invariant not satisfied"); (* A reserved borrow can't point to a value inside an abstraction *) - sanity_check (kind <> BReserved || not info.loan_in_abs) meta; + sanity_check __FILE__ __LINE__ (kind <> BReserved || not info.loan_in_abs) meta; (* Insert the borrow id *) let borrow_ids = info.borrow_ids in - sanity_check (not (BorrowId.Set.mem bid borrow_ids)) meta; + sanity_check __FILE__ __LINE__ (not (BorrowId.Set.mem bid borrow_ids)) meta; let info = { info with borrow_ids = BorrowId.Set.add bid borrow_ids } in (* Update the info in the map *) update_info bid info @@ -270,7 +270,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : List.iter (fun (rkind, bid) -> let info = find_info bid in - sanity_check (info.loan_kind = rkind) meta) + sanity_check __FILE__ __LINE__ (info.loan_kind = rkind) meta) !ignored_loans; (* Then, check the borrow infos *) @@ -278,12 +278,12 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : (fun _ info -> (* Note that we can't directly compare the sets - I guess they are * different depending on the order in which we add the elements... *) - sanity_check + sanity_check __FILE__ __LINE__ (BorrowId.Set.elements info.loan_ids = BorrowId.Set.elements info.borrow_ids) meta; match info.loan_kind with - | RMut -> sanity_check (BorrowId.Set.cardinal info.loan_ids = 1) meta + | RMut -> sanity_check __FILE__ __LINE__ (BorrowId.Set.cardinal info.loan_ids = 1) meta | RShared -> ()) !borrows_infos @@ -298,7 +298,7 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = method! visit_VBottom info = (* No ⊥ inside borrowed values *) - sanity_check + sanity_check __FILE__ __LINE__ (Config.allow_bottom_below_borrow || not info.outer_borrow) meta @@ -313,7 +313,7 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | VSharedLoan (_, _) -> set_outer_shared info | VMutLoan _ -> (* No mutable loan inside a shared loan *) - sanity_check (not info.outer_shared) meta; + sanity_check __FILE__ __LINE__ (not info.outer_shared) meta; set_outer_mut info in (* Continue exploring *) @@ -325,7 +325,7 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = match bc with | VSharedBorrow _ -> set_outer_shared info | VReservedMutBorrow _ -> - sanity_check (not info.outer_borrow) meta; + sanity_check __FILE__ __LINE__ (not info.outer_borrow) meta; set_outer_shared info | VMutBorrow (_, _) -> set_outer_mut info in @@ -373,9 +373,9 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : unit = match (cv, ty) with - | VScalar sv, TInteger int_ty -> sanity_check (sv.int_ty = int_ty) meta + | VScalar sv, TInteger int_ty -> sanity_check __FILE__ __LINE__ (sv.int_ty = int_ty) meta | VBool _, TBool | VChar _, TChar -> () - | _ -> craise meta "Erroneous typing" + | _ -> craise __FILE__ __LINE__ meta "Erroneous typing" let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (* TODO: the type of aloans doens't make sense: they have a type @@ -397,17 +397,17 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = method! visit_EBinding info binder v = (* We also check that the regions are erased *) - sanity_check (ty_is_ety v.ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_ety v.ty) meta; super#visit_EBinding info binder v method! visit_symbolic_value inside_abs v = (* Check that the types have regions *) - sanity_check (ty_is_rty v.sv_ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty v.sv_ty) meta; super#visit_symbolic_value inside_abs v method! visit_typed_value info tv = (* Check that the types have erased regions *) - sanity_check (ty_is_ety tv.ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_ety tv.ty) meta; (* Check the current pair (value, type) *) (match (tv.value, tv.ty) with | VLiteral cv, TLiteral ty -> check_literal_type meta cv ty @@ -417,20 +417,20 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - sanity_check + sanity_check __FILE__ __LINE__ (List.length generics.regions = List.length def.generics.regions) meta; - sanity_check + sanity_check __FILE__ __LINE__ (List.length generics.types = List.length def.generics.types) meta; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - sanity_check + sanity_check __FILE__ __LINE__ (VariantId.to_int variant_id < List.length variants) meta | None, Struct _ -> () - | _ -> craise meta "Erroneous typing"); + | _ -> craise __FILE__ __LINE__ meta "Erroneous typing"); (* Check that the field types are correct *) let field_types = AssociatedTypes.type_decl_get_inst_norm_field_etypes meta ctx def @@ -439,13 +439,13 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let fields_with_types = List.combine av.field_values field_types in List.iter (fun ((v, ty) : typed_value * ty) -> - sanity_check (v.ty = ty) meta) + sanity_check __FILE__ __LINE__ (v.ty = ty) meta) fields_with_types (* Tuple case *) | VAdt av, TAdt (TTuple, generics) -> - sanity_check (generics.regions = []) meta; - sanity_check (generics.const_generics = []) meta; - sanity_check (av.variant_id = None) meta; + sanity_check __FILE__ __LINE__ (generics.regions = []) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (av.variant_id = None) meta; (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) let fields_with_types = @@ -453,11 +453,11 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = in List.iter (fun ((v, ty) : typed_value * ty) -> - sanity_check (v.ty = ty) meta) + sanity_check __FILE__ __LINE__ (v.ty = ty) meta) fields_with_types (* Assumed type case *) | VAdt av, TAdt (TAssumed aty_id, generics) -> ( - sanity_check (av.variant_id = None) meta; + sanity_check __FILE__ __LINE__ (av.variant_id = None) meta; match ( aty_id, av.field_values, @@ -467,10 +467,10 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = with (* Box *) | TBox, [ inner_value ], [], [ inner_ty ], [] -> - sanity_check (inner_value.ty = inner_ty) meta + sanity_check __FILE__ __LINE__ (inner_value.ty = inner_ty) meta | TArray, inner_values, _, [ inner_ty ], [ cg ] -> (* *) - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun (v : typed_value) -> v.ty = inner_ty) inner_values) @@ -481,9 +481,9 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (TypesUtils.const_generic_as_literal cg)) .value in - sanity_check (Z.of_int (List.length inner_values) = len) meta - | (TSlice | TStr), _, _, _, _ -> craise meta "Unexpected" - | _ -> craise meta "Erroneous type") + sanity_check __FILE__ __LINE__ (Z.of_int (List.length inner_values) = len) meta + | (TSlice | TStr), _, _, _, _ -> craise __FILE__ __LINE__ meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Erroneous type") | VBottom, _ -> (* Nothing to check *) () | VBorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with @@ -493,30 +493,30 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - sanity_check (sv.ty = ref_ty) meta - | _ -> craise meta "Inconsistent context") + sanity_check __FILE__ __LINE__ (sv.ty = ref_ty) meta + | _ -> craise __FILE__ __LINE__ meta "Inconsistent context") | VMutBorrow (_, bv), RMut -> - sanity_check + sanity_check __FILE__ __LINE__ ((* Check that the borrowed value has the proper type *) bv.ty = ref_ty) meta - | _ -> craise meta "Erroneous typing") + | _ -> craise __FILE__ __LINE__ meta "Erroneous typing") | VLoan lc, ty -> ( match lc with - | VSharedLoan (_, sv) -> sanity_check (sv.ty = ty) meta + | VSharedLoan (_, sv) -> sanity_check __FILE__ __LINE__ (sv.ty = ty) meta | VMutLoan bid -> ( (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> - sanity_check (bv.ty = ty) meta + sanity_check __FILE__ __LINE__ (bv.ty = ty) meta | Abstract (AMutBorrow (_, sv)) -> - sanity_check (Substitute.erase_regions sv.ty = ty) meta - | _ -> craise meta "Inconsistent context")) + sanity_check __FILE__ __LINE__ (Substitute.erase_regions sv.ty = ty) meta + | _ -> craise __FILE__ __LINE__ meta "Inconsistent context")) | VSymbolic sv, ty -> let ty' = Substitute.erase_regions sv.sv_ty in - sanity_check (ty' = ty) meta - | _ -> craise meta "Erroneous typing"); + sanity_check __FILE__ __LINE__ (ty' = ty) meta + | _ -> craise __FILE__ __LINE__ meta "Erroneous typing"); (* Continue exploring to inspect the subterms *) super#visit_typed_value info tv @@ -530,7 +530,7 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * *) method! visit_typed_avalue info atv = (* Check that the types have regions *) - sanity_check (ty_is_rty atv.ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty atv.ty) meta; (* Check the current pair (value, type) *) (match (atv.value, atv.ty) with (* ADT case *) @@ -539,24 +539,24 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - sanity_check + sanity_check __FILE__ __LINE__ (List.length generics.regions = List.length def.generics.regions) meta; - sanity_check + sanity_check __FILE__ __LINE__ (List.length generics.types = List.length def.generics.types) meta; - sanity_check + sanity_check __FILE__ __LINE__ (List.length generics.const_generics = List.length def.generics.const_generics) meta; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - sanity_check + sanity_check __FILE__ __LINE__ (VariantId.to_int variant_id < List.length variants) meta | None, Struct _ -> () - | _ -> craise meta "Erroneous typing"); + | _ -> craise __FILE__ __LINE__ meta "Erroneous typing"); (* Check that the field types are correct *) let field_types = AssociatedTypes.type_decl_get_inst_norm_field_rtypes meta ctx def @@ -565,13 +565,13 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let fields_with_types = List.combine av.field_values field_types in List.iter (fun ((v, ty) : typed_avalue * ty) -> - sanity_check (v.ty = ty) meta) + sanity_check __FILE__ __LINE__ (v.ty = ty) meta) fields_with_types (* Tuple case *) | AAdt av, TAdt (TTuple, generics) -> - sanity_check (generics.regions = []) meta; - sanity_check (generics.const_generics = []) meta; - sanity_check (av.variant_id = None) meta; + sanity_check __FILE__ __LINE__ (generics.regions = []) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (av.variant_id = None) meta; (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) let fields_with_types = @@ -579,11 +579,11 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = in List.iter (fun ((v, ty) : typed_avalue * ty) -> - sanity_check (v.ty = ty) meta) + sanity_check __FILE__ __LINE__ (v.ty = ty) meta) fields_with_types (* Assumed type case *) | AAdt av, TAdt (TAssumed aty_id, generics) -> ( - sanity_check (av.variant_id = None) meta; + sanity_check __FILE__ __LINE__ (av.variant_id = None) meta; match ( aty_id, av.field_values, @@ -593,66 +593,66 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = with (* Box *) | TBox, [ boxed_value ], [], [ boxed_ty ], [] -> - sanity_check (boxed_value.ty = boxed_ty) meta - | _ -> craise meta "Erroneous type") + sanity_check __FILE__ __LINE__ (boxed_value.ty = boxed_ty) meta + | _ -> craise __FILE__ __LINE__ meta "Erroneous type") | ABottom, _ -> (* Nothing to check *) () | ABorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with | AMutBorrow (_, av), RMut -> (* Check that the child value has the proper type *) - sanity_check (av.ty = ref_ty) meta + sanity_check __FILE__ __LINE__ (av.ty = ref_ty) meta | ASharedBorrow bid, RShared -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan meta ek_all bid ctx in match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - sanity_check (sv.ty = Substitute.erase_regions ref_ty) meta - | _ -> craise meta "Inconsistent context") + sanity_check __FILE__ __LINE__ (sv.ty = Substitute.erase_regions ref_ty) meta + | _ -> craise __FILE__ __LINE__ meta "Inconsistent context") | AIgnoredMutBorrow (_opt_bid, av), RMut -> - sanity_check (av.ty = ref_ty) meta + sanity_check __FILE__ __LINE__ (av.ty = ref_ty) meta | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, RMut ) -> - sanity_check (given_back.ty = ref_ty) meta; - sanity_check (child.ty = ref_ty) meta + sanity_check __FILE__ __LINE__ (given_back.ty = ref_ty) meta; + sanity_check __FILE__ __LINE__ (child.ty = ref_ty) meta | AProjSharedBorrow _, RShared -> () - | _ -> craise meta "Inconsistent context") + | _ -> craise __FILE__ __LINE__ meta "Inconsistent context") | ALoan lc, aty -> ( match lc with | AMutLoan (bid, child_av) | AIgnoredMutLoan (Some bid, child_av) -> ( let borrowed_aty = aloan_get_expected_child_type aty in - sanity_check (child_av.ty = borrowed_aty) meta; + sanity_check __FILE__ __LINE__ (child_av.ty = borrowed_aty) meta; (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> - sanity_check + sanity_check __FILE__ __LINE__ (bv.ty = Substitute.erase_regions borrowed_aty) meta | Abstract (AMutBorrow (_, sv)) -> - sanity_check + sanity_check __FILE__ __LINE__ (Substitute.erase_regions sv.ty = Substitute.erase_regions borrowed_aty) meta - | _ -> craise meta "Inconsistent context") + | _ -> craise __FILE__ __LINE__ meta "Inconsistent context") | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - sanity_check (child_av.ty = borrowed_aty) meta + sanity_check __FILE__ __LINE__ (child_av.ty = borrowed_aty) meta | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - sanity_check + sanity_check __FILE__ __LINE__ (sv.ty = Substitute.erase_regions borrowed_aty) meta; (* TODO: the type of aloans doesn't make sense, see above *) - sanity_check (child_av.ty = borrowed_aty) meta + sanity_check __FILE__ __LINE__ (child_av.ty = borrowed_aty) meta | AEndedMutLoan { given_back; child; given_back_meta = _ } | AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } -> let borrowed_aty = aloan_get_expected_child_type aty in - sanity_check (given_back.ty = borrowed_aty) meta; - sanity_check (child.ty = borrowed_aty) meta + sanity_check __FILE__ __LINE__ (given_back.ty = borrowed_aty) meta; + sanity_check __FILE__ __LINE__ (child.ty = borrowed_aty) meta | AIgnoredSharedLoan child_av -> - sanity_check + sanity_check __FILE__ __LINE__ (child_av.ty = aloan_get_expected_child_type aty) meta) | ASymbolic aproj, ty -> ( @@ -660,25 +660,25 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = match aproj with | AProjLoans (sv, _) -> let ty2 = Substitute.erase_regions sv.sv_ty in - sanity_check (ty1 = ty2) meta; + sanity_check __FILE__ __LINE__ (ty1 = ty2) meta; (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - sanity_check (ty_has_regions_in_set abs.regions sv.sv_ty) meta + sanity_check __FILE__ __LINE__ (ty_has_regions_in_set abs.regions sv.sv_ty) meta | AProjBorrows (sv, proj_ty) -> let ty2 = Substitute.erase_regions sv.sv_ty in - sanity_check (ty1 = ty2) meta; + sanity_check __FILE__ __LINE__ (ty1 = ty2) meta; (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - sanity_check (ty_has_regions_in_set abs.regions proj_ty) meta + sanity_check __FILE__ __LINE__ (ty_has_regions_in_set abs.regions proj_ty) meta | AEndedProjLoans (_msv, given_back_ls) -> List.iter (fun (_, proj) -> match proj with - | AProjBorrows (_sv, ty') -> sanity_check (ty' = ty) meta + | AProjBorrows (_sv, ty') -> sanity_check __FILE__ __LINE__ (ty' = ty) meta | AEndedProjBorrows _ | AIgnoredProjBorrows -> () - | _ -> craise meta "Unexpected") + | _ -> craise __FILE__ __LINE__ meta "Unexpected") given_back_ls | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()) | AIgnored, _ -> () @@ -689,7 +689,7 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = ^ "\n- value: " ^ typed_avalue_to_string ~meta:(Some meta) ctx atv ^ "\n- type: " ^ ty_to_string ctx atv.ty)); - craise meta "Erroneous typing"); + craise __FILE__ __LINE__ meta "Erroneous typing"); (* Continue exploring to inspect the subterms *) super#visit_typed_avalue info atv end @@ -796,17 +796,17 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = *) (* A symbolic value can't be both in the regular environment and inside * projectors of borrows in abstractions *) - sanity_check (info.env_count = 0 || info.aproj_borrows = []) meta; + sanity_check __FILE__ __LINE__ (info.env_count = 0 || info.aproj_borrows = []) meta; (* A symbolic value containing borrows can't be duplicated (i.e., copied): * it must be expanded first *) if ty_has_borrows ctx.type_ctx.type_infos info.ty then - sanity_check (info.env_count <= 1) meta; + sanity_check __FILE__ __LINE__ (info.env_count <= 1) meta; (* A duplicated symbolic value is necessarily primitively copyable *) - sanity_check + sanity_check __FILE__ __LINE__ (info.env_count <= 1 || ty_is_primitively_copyable info.ty) meta; - sanity_check (info.aproj_borrows = [] || info.aproj_loans <> []) meta; + sanity_check __FILE__ __LINE__ (info.aproj_borrows = [] || info.aproj_loans <> []) meta; (* At the same time: * - check that the loans don't intersect * - compute the set of regions for which we project loans @@ -818,7 +818,7 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = let regions = RegionId.Set.fold (fun rid regions -> - sanity_check (not (RegionId.Set.mem rid regions)) meta; + sanity_check __FILE__ __LINE__ (not (RegionId.Set.mem rid regions)) meta; RegionId.Set.add rid regions) regions linfo.regions in @@ -828,7 +828,7 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Check that the union of the loan projectors contains the borrow projections. *) List.iter (fun binfo -> - sanity_check + sanity_check __FILE__ __LINE__ (projection_contains meta info.ty loan_regions binfo.proj_ty binfo.regions) meta) diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index 8c346a8c..5e0aa289 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -217,11 +217,11 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = method! visit_statement entered_loop st = match st.content with | Loop loop -> - cassert (not entered_loop) st.meta + cassert __FILE__ __LINE__ (not entered_loop) st.meta "Nested loops are not supported yet"; { st with content = super#visit_Loop true loop } | Break i -> - cassert (i = 0) st.meta + cassert __FILE__ __LINE__ (i = 0) st.meta "Breaks to outer loops are not supported yet"; { st with content = nst.content } | _ -> super#visit_statement entered_loop st @@ -238,7 +238,7 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = method! visit_Sequence env st1 st2 = match st1.content with | Loop _ -> - sanity_check (statement_has_no_loop_break_continue st2) st2.meta; + sanity_check __FILE__ __LINE__ (statement_has_no_loop_break_continue st2) st2.meta; (replace_breaks_with st1 st2).content | _ -> super#visit_Sequence env st1 st2 end @@ -405,7 +405,7 @@ let remove_shallow_borrows (crate : crate) (f : fun_decl) : fun_decl = method! visit_statement _ st = super#visit_statement st.meta st method! visit_var_id meta id = - cassert + cassert __FILE__ __LINE__ (not (VarId.Set.mem id !filtered)) meta "Filtered variables should have completely disappeared from the \ diff --git a/compiler/Print.ml b/compiler/Print.ml index b570bf5f..a136f87e 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -85,9 +85,9 @@ module Values = struct (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" | _ -> - craise_opt_meta meta + craise_opt_meta __FILE__ __LINE__ meta ("Inconsistent value: " ^ show_typed_value v)) - | _ -> craise_opt_meta meta "Inconsistent typed value") + | _ -> craise_opt_meta __FILE__ __LINE__ meta "Inconsistent typed value") | VBottom -> "⊥ : " ^ ty_to_string env v.ty | VBorrow bc -> borrow_content_to_string ~meta env bc | VLoan lc -> loan_content_to_string ~meta env lc @@ -183,8 +183,8 @@ module Values = struct (* Assumed type *) match (aty, field_values) with | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" - | _ -> craise_opt_meta meta "Inconsistent value") - | _ -> craise_opt_meta meta "Inconsistent typed value") + | _ -> craise_opt_meta __FILE__ __LINE__ meta "Inconsistent value") + | _ -> craise_opt_meta __FILE__ __LINE__ meta "Inconsistent typed value") | ABottom -> "⊥ : " ^ ty_to_string env v.ty | ABorrow bc -> aborrow_content_to_string ~meta env bc | ALoan lc -> aloan_content_to_string ~meta env lc @@ -343,7 +343,7 @@ module Contexts = struct in indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string ~meta env tv ^ " ;" | EAbs abs -> abs_to_string ~meta env verbose indent indent_incr abs - | EFrame -> craise_opt_meta meta "Can't print a Frame element" + | EFrame -> craise_opt_meta __FILE__ __LINE__ meta "Can't print a Frame element" let opt_env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) @@ -498,7 +498,7 @@ module Contexts = struct | EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 | EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 | EAbs _ -> num_abs := !num_abs + 1 - | _ -> craise_opt_meta meta "Unreachable") + | _ -> craise_opt_meta __FILE__ __LINE__ meta "Unreachable") f; "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " ^ string_of_int !num_bindings diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 1162251a..a1b19ea3 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -308,34 +308,34 @@ let adt_variant_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) match aty with | TState | TArray | TSlice | TStr | TRawPtr _ -> (* Those types are opaque: we can't get there *) - craise_opt_meta meta "Unreachable" + craise_opt_meta __FILE__ __LINE__ meta "Unreachable" | TResult -> let variant_id = Option.get variant_id in if variant_id = result_return_id then "@Result::Return" else if variant_id = result_fail_id then "@Result::Fail" else - craise_opt_meta meta + craise_opt_meta __FILE__ __LINE__ meta "Unreachable: improper variant id for result type" | TError -> let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" else - craise_opt_meta meta + craise_opt_meta __FILE__ __LINE__ meta "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then "@Fuel::Zero" else if variant_id = fuel_succ_id then "@Fuel::Succ" else - craise_opt_meta meta + craise_opt_meta __FILE__ __LINE__ meta "Unreachable: improper variant id for fuel type") let adt_field_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) (field_id : FieldId.id) : string = match adt_id with | TTuple -> - craise_opt_meta meta "Unreachable" + craise_opt_meta __FILE__ __LINE__ meta "Unreachable" (* Tuples don't use the opaque field id for the field indices, but [int] *) | TAdtId def_id -> ( (* "Regular" ADT *) @@ -348,10 +348,10 @@ let adt_field_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) match aty with | TState | TFuel | TArray | TSlice | TStr -> (* Opaque types: we can't get there *) - craise_opt_meta meta "Unreachable" + craise_opt_meta __FILE__ __LINE__ meta "Unreachable" | TResult | TError | TRawPtr _ -> (* Enumerations: we can't get there *) - craise_opt_meta meta "Unreachable") + craise_opt_meta __FILE__ __LINE__ meta "Unreachable") (** TODO: we don't need a general function anymore (it is now only used for patterns) @@ -391,49 +391,49 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) match aty with | TState | TRawPtr _ -> (* This type is opaque: we can't get there *) - craise_opt_meta meta "Unreachable" + craise_opt_meta __FILE__ __LINE__ meta "Unreachable" | TResult -> let variant_id = Option.get variant_id in if variant_id = result_return_id then match field_values with | [ v ] -> "@Result::Return " ^ v - | _ -> craise_opt_meta meta "Result::Return takes exactly one value" + | _ -> craise_opt_meta __FILE__ __LINE__ meta "Result::Return takes exactly one value" else if variant_id = result_fail_id then match field_values with | [ v ] -> "@Result::Fail " ^ v - | _ -> craise_opt_meta meta "Result::Fail takes exactly one value" + | _ -> craise_opt_meta __FILE__ __LINE__ meta "Result::Fail takes exactly one value" else - craise_opt_meta meta + craise_opt_meta __FILE__ __LINE__ meta "Unreachable: improper variant id for result type" | TError -> - cassert_opt_meta (field_values = []) meta "TODO: error message"; + cassert_opt_meta __FILE__ __LINE__ (field_values = []) meta "TODO: error message"; let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" else - craise_opt_meta meta + craise_opt_meta __FILE__ __LINE__ meta "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then ( - cassert_opt_meta (field_values = []) meta "TODO: error message"; + cassert_opt_meta __FILE__ __LINE__ (field_values = []) meta "TODO: error message"; "@Fuel::Zero") else if variant_id = fuel_succ_id then match field_values with | [ v ] -> "@Fuel::Succ " ^ v - | _ -> craise_opt_meta meta "@Fuel::Succ takes exactly one value" + | _ -> craise_opt_meta __FILE__ __LINE__ meta "@Fuel::Succ takes exactly one value" else - craise_opt_meta meta + craise_opt_meta __FILE__ __LINE__ meta "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr -> - cassert_opt_meta (variant_id = None) meta "TODO: error message"; + cassert_opt_meta __FILE__ __LINE__ (variant_id = None) meta "TODO: error message"; let field_values = List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values in let id = assumed_ty_to_string aty in id ^ " [" ^ String.concat "; " field_values ^ "]") | _ -> - craise_opt_meta meta + craise_opt_meta __FILE__ __LINE__ meta ("Inconsistently typed value: expected ADT type but found:" ^ "\n- ty: " ^ ty_to_string env false ty ^ "\n- variant_id: " ^ Print.option_to_string VariantId.to_string variant_id) @@ -597,7 +597,7 @@ let rec texpression_to_string ?(metadata : Meta.meta option = None) supd.updates in "[ " ^ String.concat ", " fields ^ " ]" - | _ -> craise_opt_meta metadata "Unexpected") + | _ -> craise_opt_meta __FILE__ __LINE__ metadata "Unexpected") | Meta (meta, e) -> ( let meta_s = emeta_to_string ~metadata env meta in let e = texpression_to_string ~metadata env inside indent indent_incr e in diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index e58b318a..95c74a7b 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -222,7 +222,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = (* Register a variable for constraints propagation - used when an variable is * introduced (left-hand side of a left binding) *) let register_var (ctx : pn_ctx) (v : var) : pn_ctx = - sanity_check (not (VarId.Map.mem v.id ctx.pure_vars)) def.meta; + sanity_check __FILE__ __LINE__ (not (VarId.Map.mem v.id ctx.pure_vars)) def.meta; match v.basename with | None -> ctx | Some name -> @@ -756,7 +756,7 @@ let simplify_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = else if variant_id = result_fail_id then (* Fail case *) self#visit_expression env rv.e - else craise def.meta "Unexpected" + else craise __FILE__ __LINE__ def.meta "Unexpected" | App _ -> (* This might be the tuple case *) if not monadic then @@ -1198,13 +1198,13 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = in let fields = match adt_decl.kind with - | Enum _ | Opaque -> craise def.meta "Unreachable" + | Enum _ | Opaque -> craise __FILE__ __LINE__ def.meta "Unreachable" | Struct fields -> fields in let num_fields = List.length fields in (* In order to simplify, there must be as many arguments as * there are fields *) - sanity_check (num_fields > 0) def.meta; + sanity_check __FILE__ __LINE__ (num_fields > 0) def.meta; if num_fields = List.length args then (* We now need to check that all the arguments are of the form: * [x.field] for some variable [x], and where the projection @@ -1240,7 +1240,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = if List.for_all (fun (_, y) -> y = x) end_args then ( (* We can substitute *) (* Sanity check: all types correct *) - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun (generics1, _) -> generics1 = generics) args) @@ -1399,7 +1399,7 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : { fwd_info; effect_info = loop_fwd_effect_info; ignore_output } in - cassert + cassert __FILE__ __LINE__ (fun_sig_info_is_wf loop_fwd_sig_info) def.meta "TODO: error message"; @@ -1441,7 +1441,7 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : (* Introduce the forward input state *) let fwd_state_var, fwd_state_lvs = - cassert + cassert __FILE__ __LINE__ (loop_fwd_effect_info.stateful = Option.is_some loop.input_state) def.meta "TODO: error message"; @@ -1577,7 +1577,7 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = let arg, args = Collections.List.pop args in mk_apps def.meta arg args | BoxFree -> - sanity_check (args = []) def.meta; + sanity_check __FILE__ __LINE__ (args = []) def.meta; mk_unit_rvalue | SliceIndexShared | SliceIndexMut | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut @@ -1772,7 +1772,7 @@ let unfold_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = (* TODO: this information should be computed in SymbolicToPure and * store in an enum ("monadic" should be an enum, not a bool). *) let re_ty = Option.get (opt_destruct_result def.meta re.ty) in - sanity_check (lv.ty = re_ty) def.meta; + sanity_check __FILE__ __LINE__ (lv.ty = re_ty) def.meta; let err_vid = fresh_id () in let err_var : var = { @@ -2025,7 +2025,7 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : ^ String.concat ", " (List.map (var_to_string ctx) inputs_prefix) ^ "\n")); let inputs_set = VarId.Set.of_list (List.map var_get_id inputs_prefix) in - sanity_check (Option.is_some decl.loop_id) decl.meta; + sanity_check __FILE__ __LINE__ (Option.is_some decl.loop_id) decl.meta; let fun_id = (E.FRegular decl.def_id, decl.loop_id) in @@ -2177,7 +2177,7 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : in let fwd_info = { fwd_info; effect_info; ignore_output } in - sanity_check (fun_sig_info_is_wf fwd_info) decl.meta; + sanity_check __FILE__ __LINE__ (fun_sig_info_is_wf fwd_info) decl.meta; let signature = { generics; diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 7576af90..9e144c50 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -15,9 +15,9 @@ let get_adt_field_types (meta : Meta.meta) match type_id with | TTuple -> (* Tuple *) - sanity_check (generics.const_generics = []) meta; - sanity_check (generics.trait_refs = []) meta; - sanity_check (variant_id = None) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (generics.trait_refs = []) meta; + sanity_check __FILE__ __LINE__ (variant_id = None) meta; generics.types | TAdtId def_id -> (* "Regular" ADT *) @@ -28,17 +28,17 @@ let get_adt_field_types (meta : Meta.meta) match aty with | TState -> (* This type is opaque *) - craise meta "Unreachable: opaque type" + craise __FILE__ __LINE__ meta "Unreachable: opaque type" | TResult -> let ty = Collections.List.to_cons_nil generics.types in let variant_id = Option.get variant_id in if variant_id = result_return_id then [ ty ] else if variant_id = result_fail_id then [ mk_error_ty ] - else craise meta "Unreachable: improper variant id for result type" + else craise __FILE__ __LINE__ meta "Unreachable: improper variant id for result type" | TError -> - sanity_check (generics = empty_generic_args) meta; + sanity_check __FILE__ __LINE__ (generics = empty_generic_args) meta; let variant_id = Option.get variant_id in - sanity_check + sanity_check __FILE__ __LINE__ (variant_id = error_failure_id || variant_id = error_out_of_fuel_id) meta; [] @@ -46,11 +46,11 @@ let get_adt_field_types (meta : Meta.meta) let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then [] else if variant_id = fuel_succ_id then [ mk_fuel_ty ] - else craise meta "Unreachable: improper variant id for fuel type" + else craise __FILE__ __LINE__ meta "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr | TRawPtr _ -> (* Array: when not symbolic values (for instance, because of aggregates), the array expressions are introduced as struct updates *) - craise meta "Attempting to access the fields of an opaque type") + craise __FILE__ __LINE__ meta "Attempting to access the fields of an opaque type") type tc_ctx = { type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) @@ -64,9 +64,9 @@ type tc_ctx = { let check_literal (meta : Meta.meta) (v : literal) (ty : literal_type) : unit = match (ty, v) with - | TInteger int_ty, VScalar sv -> sanity_check (int_ty = sv.int_ty) meta + | TInteger int_ty, VScalar sv -> sanity_check __FILE__ __LINE__ (int_ty = sv.int_ty) meta | TBool, VBool _ | TChar, VChar _ -> () - | _ -> craise meta "Inconsistent type" + | _ -> craise __FILE__ __LINE__ meta "Inconsistent type" let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = @@ -77,7 +77,7 @@ let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) ctx | PatDummy -> ctx | PatVar (var, _) -> - sanity_check (var.ty = v.ty) meta; + sanity_check __FILE__ __LINE__ (var.ty = v.ty) meta; let env = VarId.Map.add var.id var.ty ctx.env in { ctx with env } | PatAdt av -> @@ -92,7 +92,7 @@ let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) log#serror ("check_typed_pattern: not the same types:" ^ "\n- ty: " ^ show_ty ty ^ "\n- v.ty: " ^ show_ty v.ty); - craise meta "Inconsistent types"); + craise __FILE__ __LINE__ meta "Inconsistent types"); check_typed_pattern meta ctx v in (* Check the field types: check that the field patterns have the expected @@ -112,21 +112,21 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : * we use a locally nameless representation *) match VarId.Map.find_opt var_id ctx.env with | None -> () - | Some ty -> sanity_check (ty = e.ty) meta) + | Some ty -> sanity_check __FILE__ __LINE__ (ty = e.ty) meta) | CVar cg_id -> let ty = T.ConstGenericVarId.Map.find cg_id ctx.const_generics in - sanity_check (ty = e.ty) meta + sanity_check __FILE__ __LINE__ (ty = e.ty) meta | Const cv -> check_literal meta cv (ty_as_literal meta e.ty) | App (app, arg) -> let input_ty, output_ty = destruct_arrow meta app.ty in - sanity_check (input_ty = arg.ty) meta; - sanity_check (output_ty = e.ty) meta; + sanity_check __FILE__ __LINE__ (input_ty = arg.ty) meta; + sanity_check __FILE__ __LINE__ (output_ty = e.ty) meta; check_texpression meta ctx app; check_texpression meta ctx arg | Lambda (pat, body) -> let pat_ty, body_ty = destruct_arrow meta e.ty in - sanity_check (pat.ty = pat_ty) meta; - sanity_check (body.ty = body_ty) meta; + sanity_check __FILE__ __LINE__ (pat.ty = pat_ty) meta; + sanity_check __FILE__ __LINE__ (body.ty = body_ty) meta; (* Check the pattern and register the introduced variables at the same time *) let ctx = check_typed_pattern meta ctx pat in check_texpression meta ctx body @@ -141,8 +141,8 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : let adt_ty, field_ty = destruct_arrow meta e.ty in let adt_id, adt_generics = ty_as_adt meta adt_ty in (* Check the ADT type *) - sanity_check (adt_id = proj_adt_id) meta; - sanity_check (adt_generics = qualif.generics) meta; + sanity_check __FILE__ __LINE__ (adt_id = proj_adt_id) meta; + sanity_check __FILE__ __LINE__ (adt_generics = qualif.generics) meta; (* Retrieve and check the expected field type *) let variant_id = None in let expected_field_tys = @@ -150,25 +150,25 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : qualif.generics in let expected_field_ty = FieldId.nth expected_field_tys field_id in - sanity_check (expected_field_ty = field_ty) meta + sanity_check __FILE__ __LINE__ (expected_field_ty = field_ty) meta | AdtCons id -> ( let expected_field_tys = get_adt_field_types meta ctx.type_decls id.adt_id id.variant_id qualif.generics in let field_tys, adt_ty = destruct_arrows e.ty in - sanity_check (expected_field_tys = field_tys) meta; + sanity_check __FILE__ __LINE__ (expected_field_tys = field_tys) meta; match adt_ty with | TAdt (type_id, generics) -> - sanity_check (type_id = id.adt_id) meta; - sanity_check (generics = qualif.generics) meta - | _ -> craise meta "Unreachable")) + sanity_check __FILE__ __LINE__ (type_id = id.adt_id) meta; + sanity_check __FILE__ __LINE__ (generics = qualif.generics) meta + | _ -> craise __FILE__ __LINE__ meta "Unreachable")) | Let (monadic, pat, re, e_next) -> let expected_pat_ty = if monadic then destruct_result meta re.ty else re.ty in - sanity_check (pat.ty = expected_pat_ty) meta; - sanity_check (e.ty = e_next.ty) meta; + sanity_check __FILE__ __LINE__ (pat.ty = expected_pat_ty) meta; + sanity_check __FILE__ __LINE__ (e.ty = e_next.ty) meta; (* Check the right-expression *) check_texpression meta ctx re; (* Check the pattern and register the introduced variables at the same time *) @@ -179,20 +179,20 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : check_texpression meta ctx scrut; match switch_body with | If (e_then, e_else) -> - sanity_check (scrut.ty = TLiteral TBool) meta; - sanity_check (e_then.ty = e.ty) meta; - sanity_check (e_else.ty = e.ty) meta; + sanity_check __FILE__ __LINE__ (scrut.ty = TLiteral TBool) meta; + sanity_check __FILE__ __LINE__ (e_then.ty = e.ty) meta; + sanity_check __FILE__ __LINE__ (e_else.ty = e.ty) meta; check_texpression meta ctx e_then; check_texpression meta ctx e_else | Match branches -> let check_branch (br : match_branch) : unit = - sanity_check (br.pat.ty = scrut.ty) meta; + sanity_check __FILE__ __LINE__ (br.pat.ty = scrut.ty) meta; let ctx = check_typed_pattern meta ctx br.pat in check_texpression meta ctx br.branch in List.iter check_branch branches) | Loop loop -> - sanity_check (loop.fun_end.ty = e.ty) meta; + sanity_check __FILE__ __LINE__ (loop.fun_end.ty = e.ty) meta; check_texpression meta ctx loop.fun_end; check_texpression meta ctx loop.loop_body | StructUpdate supd -> ( @@ -200,11 +200,11 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : (if Option.is_some supd.init then match VarId.Map.find_opt (Option.get supd.init) ctx.env with | None -> () - | Some ty -> sanity_check (ty = e.ty) meta); + | Some ty -> sanity_check __FILE__ __LINE__ (ty = e.ty) meta); (* Check the fields *) (* Retrieve and check the expected field type *) let adt_id, adt_generics = ty_as_adt meta e.ty in - sanity_check (adt_id = supd.struct_id) meta; + sanity_check __FILE__ __LINE__ (adt_id = supd.struct_id) meta; (* The id can only be: a custom type decl or an array *) match adt_id with | TAdtId _ -> @@ -216,7 +216,7 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : List.iter (fun ((fid, fe) : _ * texpression) -> let expected_field_ty = FieldId.nth expected_field_tys fid in - sanity_check (expected_field_ty = fe.ty) meta; + sanity_check __FILE__ __LINE__ (expected_field_ty = fe.ty) meta; check_texpression meta ctx fe) supd.updates | TAssumed TArray -> @@ -225,10 +225,10 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : in List.iter (fun ((_, fe) : _ * texpression) -> - sanity_check (expected_field_ty = fe.ty) meta; + sanity_check __FILE__ __LINE__ (expected_field_ty = fe.ty) meta; check_texpression meta ctx fe) supd.updates - | _ -> craise meta "Unexpected") + | _ -> craise __FILE__ __LINE__ meta "Unexpected") | Meta (_, e_next) -> - sanity_check (e_next.ty = e.ty) meta; + sanity_check __FILE__ __LINE__ (e_next.ty = e.ty) meta; check_texpression meta ctx e_next diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 328f757a..215bebe3 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -78,7 +78,7 @@ let fun_sig_info_is_wf (info : fun_sig_info) : bool = let dest_arrow_ty (meta : Meta.meta) (ty : ty) : ty * ty = match ty with | TArrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) - | _ -> craise meta "Not an arrow type" + | _ -> craise __FILE__ __LINE__ meta "Not an arrow type" let compute_literal_type (cv : literal) : literal_type = match cv with @@ -227,7 +227,7 @@ let rec let_group_requires_parentheses (meta : Meta.meta) (e : texpression) : true | Loop _ -> (* Should have been eliminated *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" let texpression_requires_parentheses meta e = match !Config.backend with @@ -238,7 +238,7 @@ let is_var (e : texpression) : bool = match e.e with Var _ -> true | _ -> false let as_var (meta : Meta.meta) (e : texpression) : VarId.id = - match e.e with Var v -> v | _ -> craise meta "Not a var" + match e.e with Var v -> v | _ -> craise __FILE__ __LINE__ meta "Not a var" let is_cvar (e : texpression) : bool = match e.e with CVar _ -> true | _ -> false @@ -252,7 +252,7 @@ let is_const (e : texpression) : bool = let ty_as_adt (meta : Meta.meta) (ty : ty) : type_id * generic_args = match ty with | TAdt (id, generics) -> (id, generics) - | _ -> craise meta "Not an ADT" + | _ -> craise __FILE__ __LINE__ meta "Not an ADT" (** Remove the external occurrences of {!Meta} *) let rec unmeta (e : texpression) : texpression = @@ -295,7 +295,7 @@ let destruct_lets_no_interleave (meta : Meta.meta) (e : texpression) : let m = match e.e with | Let (monadic, _, _, _) -> monadic - | _ -> craise meta "Not a let-binding" + | _ -> craise __FILE__ __LINE__ meta "Not a let-binding" in (* Destruct the rest *) let rec destruct_lets (e : texpression) : @@ -325,7 +325,7 @@ let destruct_apps (e : texpression) : texpression * texpression list = let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : texpression = let raise_or_return msg = - save_error (Some meta) msg; + save_error __FILE__ __LINE__ (Some meta) msg; let e = App (app, arg) in (* Dummy type - TODO: introduce an error type *) let ty = app.ty in @@ -373,8 +373,8 @@ let opt_destruct_function_call (e : texpression) : let opt_destruct_result (meta : Meta.meta) (ty : ty) : ty option = match ty with | TAdt (TAssumed TResult, generics) -> - sanity_check (generics.const_generics = []) meta; - sanity_check (generics.trait_refs = []) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (generics.trait_refs = []) meta; Some (Collections.List.to_cons_nil generics.types) | _ -> None @@ -384,15 +384,15 @@ let destruct_result (meta : Meta.meta) (ty : ty) : ty = let opt_destruct_tuple (meta : Meta.meta) (ty : ty) : ty list option = match ty with | TAdt (TTuple, generics) -> - sanity_check (generics.const_generics = []) meta; - sanity_check (generics.trait_refs = []) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (generics.trait_refs = []) meta; Some generics.types | _ -> None let destruct_arrow (meta : Meta.meta) (ty : ty) : ty * ty = match ty with | TArrow (ty0, ty1) -> (ty0, ty1) - | _ -> craise meta "Not an arrow type" + | _ -> craise __FILE__ __LINE__ meta "Not an arrow type" let rec destruct_arrows (ty : ty) : ty list * ty = match ty with @@ -430,14 +430,14 @@ let mk_switch (meta : Meta.meta) (scrut : texpression) (sb : switch_body) : texpression = (* Sanity check: the scrutinee has the proper type *) (match sb with - | If (_, _) -> sanity_check (scrut.ty = TLiteral TBool) meta + | If (_, _) -> sanity_check __FILE__ __LINE__ (scrut.ty = TLiteral TBool) meta | Match branches -> List.iter - (fun (b : match_branch) -> sanity_check (b.pat.ty = scrut.ty) meta) + (fun (b : match_branch) -> sanity_check __FILE__ __LINE__ (b.pat.ty = scrut.ty) meta) branches); (* Sanity check: all the branches have the same type *) let ty = get_switch_body_ty sb in - iter_switch_body_branches (fun e -> sanity_check (e.ty = ty) meta) sb; + iter_switch_body_branches (fun e -> sanity_check __FILE__ __LINE__ (e.ty = ty) meta) sb; (* Put together *) let e = Switch (scrut, sb) in { e; ty } @@ -526,10 +526,10 @@ let mk_adt_pattern (adt_ty : ty) (variant_id : VariantId.id option) let ty_as_integer (meta : Meta.meta) (t : ty) : T.integer_type = match t with | TLiteral (TInteger int_ty) -> int_ty - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" let ty_as_literal (meta : Meta.meta) (t : ty) : T.literal_type = - match t with TLiteral ty -> ty | _ -> craise meta "Unreachable" + match t with TLiteral ty -> ty | _ -> craise __FILE__ __LINE__ meta "Unreachable" let mk_state_ty : ty = TAdt (TAssumed TState, empty_generic_args) @@ -552,7 +552,7 @@ let unwrap_result_ty (meta : Meta.meta) (ty : ty) : ty = ( TAssumed TResult, { types = [ ty ]; const_generics = []; trait_refs = [] } ) -> ty - | _ -> craise meta "not a result type" + | _ -> craise __FILE__ __LINE__ meta "not a result type" let mk_result_fail_texpression (meta : Meta.meta) (error : texpression) (ty : ty) : texpression = diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index 7267dd3d..713cdef9 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -108,8 +108,8 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) let add_edge ~(short : region) ~(long : region) = (* Sanity checks *) - sanity_check_opt_meta (short <> RErased) meta; - sanity_check_opt_meta (long <> RErased) meta; + sanity_check_opt_meta __FILE__ __LINE__ (short <> RErased) meta; + sanity_check_opt_meta __FILE__ __LINE__ (long <> RErased) meta; (* Ignore the locally bound regions (at the level of arrow types for instance *) match (short, long) with | RBVar _, _ | _, RBVar _ -> () @@ -175,14 +175,14 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) | TTraitType (trait_ref, _) -> (* The trait should reference a clause, and not an implementation (otherwise it should have been normalized) *) - sanity_check_opt_meta + sanity_check_opt_meta __FILE__ __LINE__ (AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id) meta; (* We have nothing to do *) () | TArrow (regions, inputs, output) -> (* TODO: *) - cassert_opt_meta (regions = []) meta + cassert_opt_meta __FILE__ __LINE__ (regions = []) meta "We don't support arrow types with locally quantified regions"; (* We can ignore the outer regions *) List.iter (explore_ty []) (output :: inputs) @@ -226,7 +226,7 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (SccId.Map.bindings sccs.sccs) in (* The SCC should only contain the 'static *) - sanity_check_opt_meta (static_scc = [ RStatic ]) meta; + sanity_check_opt_meta __FILE__ __LINE__ (static_scc = [ RStatic ]) meta; (* Remove the group as well as references to this group from the other SCCs *) let { sccs; scc_deps } = sccs in @@ -282,7 +282,7 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (fun r -> match r with | RFVar rid -> RegionId.Map.find rid region_id_to_var_map - | _ -> craise (Option.get meta) "Unreachable") + | _ -> craise __FILE__ __LINE__ (Option.get meta) "Unreachable") scc in diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 182dfabf..b9eebc25 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -76,19 +76,19 @@ let ctx_adt_value_get_instantiated_field_types (meta : Meta.meta) (* Retrieve the types of the fields *) ctx_adt_get_instantiated_field_types ctx id adt.variant_id generics | TTuple -> - cassert (generics.regions = []) meta + cassert __FILE__ __LINE__ (generics.regions = []) meta "Regions should be empty TODO: error message"; generics.types | TAssumed aty -> ( match aty with | TBox -> - sanity_check (generics.regions = []) meta; - sanity_check (List.length generics.types = 1) meta; - sanity_check (generics.const_generics = []) meta; + sanity_check __FILE__ __LINE__ (generics.regions = []) meta; + sanity_check __FILE__ __LINE__ (List.length generics.types = 1) meta; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; generics.types | TArray | TSlice | TStr -> (* Those types don't have fields *) - craise meta "Unreachable") + craise __FILE__ __LINE__ meta "Unreachable") (** Substitute a function signature, together with the regions hierarchy associated to that signature. @@ -153,7 +153,7 @@ let typed_value_subst_ids (meta : Meta.meta) (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ssubst : SymbolicValueId.id -> SymbolicValueId.id) (bsubst : BorrowId.id -> BorrowId.id) (v : typed_value) : typed_value = - let asubst _ = craise meta "Unreachable" in + let asubst _ = craise __FILE__ __LINE__ meta "Unreachable" in let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_value () v @@ -172,7 +172,7 @@ let typed_avalue_subst_ids (meta : Meta.meta) (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ssubst : SymbolicValueId.id -> SymbolicValueId.id) (bsubst : BorrowId.id -> BorrowId.id) (v : typed_avalue) : typed_avalue = - let asubst _ = craise meta "Unreachable" in + let asubst _ = craise __FILE__ __LINE__ meta "Unreachable" in let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_avalue () v @@ -196,7 +196,7 @@ let env_subst_ids (r_subst : RegionId.id -> RegionId.id) let typed_avalue_subst_rids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) (x : typed_avalue) : typed_avalue = - let asubst _ = craise meta "Unreachable" in + let asubst _ = craise __FILE__ __LINE__ meta "Unreachable" in let vis = subst_ids_visitor r_subst (fun x -> x) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index db32c2ce..031c29f7 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -436,7 +436,7 @@ and translate_trait_instance_id (meta : Meta.meta) (translate_ty : T.ty -> ty) | TraitImpl id -> TraitImpl id | BuiltinOrAuto _ -> (* We should have eliminated those in the prepasses *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" | Clause id -> Clause id | ParentClause (inst_id, decl_id, clause_id) -> let inst_id = translate_trait_instance_id inst_id in @@ -445,8 +445,8 @@ and translate_trait_instance_id (meta : Meta.meta) (translate_ty : T.ty -> ty) let inst_id = translate_trait_instance_id inst_id in ItemClause (inst_id, decl_id, item_name, clause_id) | TraitRef tr -> TraitRef (translate_trait_ref meta translate_ty tr) - | FnPointer _ | Closure _ -> craise meta "Closures are not supported yet" - | UnknownTrait s -> craise meta ("Unknown trait found: " ^ s) + | FnPointer _ | Closure _ -> craise __FILE__ __LINE__ meta "Closures are not supported yet" + | UnknownTrait s -> craise __FILE__ __LINE__ meta ("Unknown trait found: " ^ s) (** Translate a signature type - TODO: factor out the different translation functions *) let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = @@ -457,7 +457,7 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = match type_id with | T.TAdtId adt_id -> TAdt (TAdtId adt_id, generics) | T.TTuple -> - cassert (generics.const_generics = []) meta "TODO: error message"; + cassert __FILE__ __LINE__ (generics.const_generics = []) meta "TODO: error message"; mk_simpl_tuple_ty generics.types | T.TAssumed aty -> ( match aty with @@ -466,14 +466,14 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = match generics.types with | [ ty ] -> ty | _ -> - craise meta + craise __FILE__ __LINE__ meta "Box/vec/option type with incorrect number of arguments") | T.TArray -> TAdt (TAssumed TArray, generics) | T.TSlice -> TAdt (TAssumed TSlice, generics) | T.TStr -> TAdt (TAssumed TStr, generics))) | TVar vid -> TVar vid | TLiteral ty -> TLiteral ty - | TNever -> craise meta "Unreachable" + | TNever -> craise __FILE__ __LINE__ meta "Unreachable" | TRef (_, rty, _) -> translate meta rty | TRawPtr (ty, rkind) -> let mut = match rkind with RMut -> Mut | RShared -> Const in @@ -483,7 +483,7 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = | TTraitType (trait_ref, type_name) -> let trait_ref = translate_strait_ref meta trait_ref in TTraitType (trait_ref, type_name) - | TArrow _ -> craise meta "TODO: error message" + | TArrow _ -> craise __FILE__ __LINE__ meta "TODO: error message" and translate_sgeneric_args (meta : Meta.meta) (generics : T.generic_args) : generic_args = @@ -567,7 +567,7 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : let name = Print.Types.name_to_string env def.name in let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) - cassert (regions = []) def.meta + cassert __FILE__ __LINE__ (regions = []) def.meta "ADTs containing borrows are not supported yet"; let trait_clauses = List.map (translate_trait_clause def.meta) trait_clauses @@ -601,7 +601,7 @@ let translate_type_id (meta : Meta.meta) (id : T.type_id) : type_id = | T.TBox -> (* Boxes have to be eliminated: this type id shouldn't be translated *) - craise meta "Unreachable" + craise __FILE__ __LINE__ meta "Unreachable" in TAssumed aty | TTuple -> TTuple @@ -632,7 +632,7 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) | TAssumed TBox -> ( (* We eliminate boxes *) (* No general parametricity for now *) - cassert + cassert __FILE__ __LINE__ (not (List.exists (TypesUtils.ty_has_borrows type_infos) @@ -641,11 +641,11 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) match t_generics.types with | [ bty ] -> bty | _ -> - craise meta + craise __FILE__ __LINE__ meta "Unreachable: box/vec/option receives exactly one type \ parameter")) | TVar vid -> TVar vid - | TNever -> craise meta "Unreachable" + | TNever -> craise __FILE__ __LINE__ meta "Unreachable" | TLiteral lty -> TLiteral lty | TRef (_, rty, _) -> translate rty | TRawPtr (ty, rkind) -> @@ -656,7 +656,7 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) | TTraitType (trait_ref, type_name) -> let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in TTraitType (trait_ref, type_name) - | TArrow _ -> craise meta "TODO: error message" + | TArrow _ -> craise __FILE__ __LINE__ meta "TODO: error message" and translate_fwd_generic_args (meta : Meta.meta) (type_infos : type_infos) (generics : T.generic_args) : generic_args = @@ -721,14 +721,14 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) else None | TAssumed TBox -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) - cassert + cassert __FILE__ __LINE__ (not (TypesUtils.ty_has_borrows type_infos ty)) meta "ADTs containing borrows are not supported yet"; (* Eliminate the box *) match generics.types with | [ bty ] -> translate bty | _ -> - craise meta + craise __FILE__ __LINE__ meta "Unreachable: boxes receive exactly one type parameter") | TTuple -> ( (* Tuples can contain borrows (which we eliminate) *) @@ -740,7 +740,7 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) * is the identity *) Some (mk_simpl_tuple_ty tys_t))) | TVar vid -> wrap (TVar vid) - | TNever -> craise meta "Unreachable" + | TNever -> craise __FILE__ __LINE__ meta "Unreachable" | TLiteral lty -> wrap (TLiteral lty) | TRef (r, rty, rkind) -> ( match rkind with @@ -765,7 +765,7 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in Some (TTraitType (trait_ref, type_name)) else None - | TArrow _ -> craise meta "TODO: error message" + | TArrow _ -> craise __FILE__ __LINE__ meta "TODO: error message" (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) @@ -817,7 +817,7 @@ let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) (back_funs : texpression option RegionGroupId.Map.t option) (ctx : bs_ctx) : bs_ctx = let calls = ctx.calls in - sanity_check (not (V.FunCallId.Map.mem call_id calls)) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (not (V.FunCallId.Map.mem call_id calls)) ctx.fun_decl.meta; let info = { forward; forward_inputs = args; back_funs } in let calls = V.FunCallId.Map.add call_id info calls in { ctx with calls } @@ -839,7 +839,7 @@ let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) let calls = V.FunCallId.Map.add call_id info ctx.calls in (* Insert the abstraction in the abstractions map *) let abstractions = ctx.abstractions in - sanity_check + sanity_check __FILE__ __LINE__ (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) ctx.fun_decl.meta; let abstractions = @@ -922,7 +922,7 @@ let compute_raw_fun_effect_info (meta : Meta.meta) is_rec = info.is_rec || Option.is_some lid; } | FunId (FAssumed aid) -> - sanity_check (lid = None) meta; + sanity_check __FILE__ __LINE__ (lid = None) meta; { can_fail = Assumed.assumed_fun_can_fail aid; stateful_group = false; @@ -953,14 +953,14 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) (* This is necessarily for the current function *) match fun_id with | FunId (FRegular fid) -> ( - sanity_check (fid = ctx.fun_decl.def_id) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (fid = ctx.fun_decl.def_id) ctx.fun_decl.meta; (* Lookup the loop *) let lid = V.LoopId.Map.find lid ctx.loop_ids_map in let loop_info = LoopId.Map.find lid ctx.loops in match gid with | None -> loop_info.fwd_effect_info | Some gid -> RegionGroupId.Map.find gid loop_info.back_effect_infos) - | _ -> craise ctx.fun_decl.meta "Unreachable") + | _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") (** Translate a function signature to a decomposed function signature. @@ -1047,8 +1047,8 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) let keep_region r = match r with | T.RStatic -> raise Unimplemented - | RErased -> craise meta "Unexpected erased region" - | RBVar _ -> craise meta "Unexpected bound region" + | RErased -> craise __FILE__ __LINE__ meta "Unexpected erased region" + | RBVar _ -> craise __FILE__ __LINE__ meta "Unexpected bound region" | RFVar rid -> T.RegionId.Set.mem rid gr_regions in let inside_mut = false in @@ -1058,7 +1058,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) (* For now we don't supported nested borrows, so we check that there aren't parent regions *) let parents = list_ancestor_region_groups regions_hierarchy gid in - cassert + cassert __FILE__ __LINE__ (T.RegionGroupId.Set.is_empty parents) meta "Nested borrows are not supported yet"; (* For now, we don't allow nested borrows, so the additional inputs to the @@ -1217,7 +1217,7 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) else false in let info = { fwd_info; effect_info = fwd_effect_info; ignore_output } in - sanity_check (fun_sig_info_is_wf info) meta; + sanity_check __FILE__ __LINE__ (fun_sig_info_is_wf info) meta; info in @@ -1506,7 +1506,7 @@ let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = match V.SymbolicValueId.Map.find_opt sv.sv_id ctx.sv_to_var with | Some v -> v | None -> - craise ctx.fun_decl.meta + craise __FILE__ __LINE__ ctx.fun_decl.meta ("Could not find var for symbolic value: " ^ V.SymbolicValueId.to_string sv.sv_id) @@ -1517,7 +1517,7 @@ let rec unbox_typed_value (meta : Meta.meta) (v : V.typed_value) : V.typed_value | V.VAdt av, T.TAdt (T.TAssumed T.TBox, _) -> ( match av.field_values with | [ bv ] -> unbox_typed_value meta bv - | _ -> craise meta "Unreachable") + | _ -> craise __FILE__ __LINE__ meta "Unreachable") | _ -> v (** Translate a symbolic value. @@ -1570,7 +1570,7 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) match v.ty with | TAdt (TTuple, _) -> - sanity_check (variant_id = None) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (variant_id = None) ctx.fun_decl.meta; mk_simpl_tuple_texpression ctx.fun_decl.meta field_values | _ -> (* Retrieve the type and the translated generics from the translated @@ -1587,11 +1587,11 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) let cons = { e = cons_e; ty = cons_ty } in (* Apply the constructor *) mk_apps ctx.fun_decl.meta cons field_values) - | VBottom -> craise ctx.fun_decl.meta "Unreachable" + | VBottom -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | VLoan lc -> ( match lc with | VSharedLoan (_, v) -> translate v - | VMutLoan _ -> craise ctx.fun_decl.meta "Unreachable") + | VMutLoan _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") | VBorrow bc -> ( match bc with | VSharedBorrow bid -> @@ -1654,7 +1654,7 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert (field_values = []) ctx.fun_decl.meta + cassert __FILE__ __LINE__ (field_values = []) ctx.fun_decl.meta "ADTs containing borrows are not supported yet"; None | TTuple -> @@ -1667,7 +1667,7 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) mk_simpl_tuple_texpression ctx.fun_decl.meta field_values in Some rv) - | ABottom -> craise ctx.fun_decl.meta "Unreachable" + | ABottom -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | ALoan lc -> aloan_content_to_consumed ctx ectx lc | ABorrow bc -> aborrow_content_to_consumed ctx bc | ASymbolic aproj -> aproj_to_consumed ctx aproj @@ -1685,7 +1685,7 @@ and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (lc : V.aloan_content) : texpression option = match lc with | AMutLoan (_, _) | ASharedLoan (_, _, _) -> - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> (* Return the meta-value *) Some (typed_value_to_texpression ctx ectx given_back_meta) @@ -1697,7 +1697,7 @@ and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) None | AIgnoredMutLoan (_, _) -> (* There can be *inner* not ended mutable loans, but not outer ones *) - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | AEndedIgnoredMutLoan _ -> (* This happens with nested borrows: we need to dive in *) raise Unimplemented @@ -1709,7 +1709,7 @@ and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : texpression option = match bc with | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - craise _ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ _ctx.fun_decl.meta "Unreachable" | AEndedMutBorrow (_, _) -> (* We collect consumed values: ignore *) None @@ -1726,7 +1726,7 @@ and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = (* The symbolic value was left unchanged *) Some (symbolic_value_to_texpression ctx msv) | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> - sanity_check (child_aproj = AIgnoredProjBorrows) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (child_aproj = AIgnoredProjBorrows) ctx.fun_decl.meta; (* The symbolic value was updated *) Some (symbolic_value_to_texpression ctx mnv) | V.AEndedProjLoans (_, _) -> @@ -1735,7 +1735,7 @@ and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = raise Unimplemented | AEndedProjBorrows _ -> (* We consider consumed values *) None | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" (** Convert the abstraction values in an abstraction to consumed values. @@ -1801,20 +1801,20 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert (field_values = []) ctx.fun_decl.meta + cassert __FILE__ __LINE__ (field_values = []) ctx.fun_decl.meta "ADTs with borrows are not supported yet"; (ctx, None) | TTuple -> (* Return *) let variant_id = adt_v.variant_id in - sanity_check (variant_id = None) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (variant_id = None) ctx.fun_decl.meta; if field_values = [] then (ctx, None) else (* Note that if there is exactly one field value, [mk_simpl_tuple_pattern] * is the identity *) let lv = mk_simpl_tuple_pattern field_values in (ctx, Some lv)) - | ABottom -> craise ctx.fun_decl.meta "Unreachable" + | ABottom -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | ALoan lc -> aloan_content_to_given_back mp lc ctx | ABorrow bc -> aborrow_content_to_given_back mp bc ctx | ASymbolic aproj -> aproj_to_given_back mp aproj ctx @@ -1830,14 +1830,14 @@ and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match lc with | AMutLoan (_, _) | ASharedLoan (_, _, _) -> - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } | AEndedSharedLoan (_, _) -> (* We consider given back values, and thus ignore those *) (ctx, None) | AIgnoredMutLoan (_, _) -> (* There can be *inner* not ended mutable loans, but not outer ones *) - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | AEndedIgnoredMutLoan _ -> (* This happens with nested borrows: we need to dive in *) raise Unimplemented @@ -1849,7 +1849,7 @@ and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match bc with | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | AEndedMutBorrow (msv, _) -> (* Return the meta-symbolic-value *) let ctx, var = fresh_var_for_symbolic_value msv ctx in @@ -1867,7 +1867,7 @@ and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : | V.AEndedProjLoans (_, child_projs) -> (* There may be children borrow projections in case of nested borrows, * in which case we need to dive in - we disallow nested borrows for now *) - cassert + cassert __FILE__ __LINE__ (List.for_all (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) child_projs) @@ -1878,7 +1878,7 @@ and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : let ctx, var = fresh_var_for_symbolic_value mv ctx in (ctx, Some (mk_typed_pattern_from_var var mp)) | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" (** Convert the abstraction values in an abstraction to given back values. @@ -2064,7 +2064,7 @@ and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) | Some _ -> (* Backward function *) (* Sanity check *) - sanity_check (opt_v = None) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (opt_v = None) ctx.fun_decl.meta; (* Group the variables in which we stored the values we need to give back. See the explanations for the [SynthInput] case in [translate_end_abstraction] *) let backward_outputs = Option.get ctx.backward_outputs in @@ -2087,9 +2087,9 @@ and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) (ctx : bs_ctx) : texpression = - sanity_check (is_continue = ctx.inside_loop) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (is_continue = ctx.inside_loop) ctx.fun_decl.meta; let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - sanity_check (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta; (* Lookup the loop information *) let loop_id = Option.get ctx.loop_id in @@ -2229,7 +2229,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : | PeIdent (s, _) -> s | PeImpl _ -> (* We shouldn't get there *) - craise decl.meta "Unexpected") + craise __FILE__ __LINE__ decl.meta "Unexpected") in name ^ "_back" in @@ -2333,7 +2333,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Neg int_ty), effect_info, args, dest) - | _ -> craise ctx.fun_decl.meta "Unreachable") + | _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") | S.Unop (E.Cast cast_kind) -> ( match cast_kind with | CastScalar (src_ty, tgt_ty) -> @@ -2350,7 +2350,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, dest) - | CastFnPtr _ -> craise ctx.fun_decl.meta "TODO: function casts") + | CastFnPtr _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "TODO: function casts") | S.Binop binop -> ( match args with | [ arg0; arg1 ] -> @@ -2359,7 +2359,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : (match binop with (* The Rust compiler accepts bitshifts for any integer type combination for ty0, ty1 *) | E.Shl | E.Shr -> () - | _ -> sanity_check (int_ty0 = int_ty1) ctx.fun_decl.meta); + | _ -> sanity_check __FILE__ __LINE__ (int_ty0 = int_ty1) ctx.fun_decl.meta); let effect_info = { can_fail = ExpressionsUtils.binop_can_fail binop; @@ -2372,7 +2372,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Binop (binop, int_ty0), effect_info, args, dest) - | _ -> craise ctx.fun_decl.meta "Unreachable") + | _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") in let func = { id = FunOrOp fun_id; generics } in let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in @@ -2429,7 +2429,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) for a parent backward function. *) let bid = Option.get ctx.bid in - sanity_check (rg_id = bid) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (rg_id = bid) ctx.fun_decl.meta; (* First, introduce the given back variables. @@ -2477,7 +2477,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) if !Config.type_check_pure_code then List.iter (fun (var, v) -> - sanity_check ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta) + sanity_check __FILE__ __LINE__ ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta) variables_values; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2498,7 +2498,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) | S.Fun (fun_id, _) -> fun_id | Unop _ | Binop _ -> (* Those don't have backward functions *) - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" in let effect_info = get_fun_effect_info ctx fun_id None (Some rg_id) in (* Retrieve the values consumed upon ending the loans inside this @@ -2571,8 +2571,8 @@ and translate_end_abstraction_identity (ectx : C.eval_ctx) (abs : V.abs) (* We can do this simply by checking that it consumes and gives back nothing *) let inputs = abs_to_consumed ctx ectx abs in let ctx, outputs = abs_to_given_back None abs ctx in - sanity_check (inputs = []) ctx.fun_decl.meta; - sanity_check (outputs = []) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (inputs = []) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (outputs = []) ctx.fun_decl.meta; (* Translate the next expression *) translate_expression e ctx @@ -2614,7 +2614,7 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) (* Retrieve the values consumed upon ending the loans inside this * abstraction: as there are no nested borrows, there should be none. *) let consumed = abs_to_consumed ctx ectx abs in - cassert (consumed = []) ctx.fun_decl.meta + cassert __FILE__ __LINE__ (consumed = []) ctx.fun_decl.meta "Nested borrows are not supported yet"; (* Retrieve the values given back upon ending this abstraction - note that * we don't provide meta-place information, because those assignments will @@ -2633,7 +2633,7 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) ^ pure_ty_to_string ctx given_back.ty ^ "\n- sig input ty: " ^ pure_ty_to_string ctx input.ty)); - sanity_check (given_back.ty = input.ty) ctx.fun_decl.meta) + sanity_check __FILE__ __LINE__ (given_back.ty = input.ty) ctx.fun_decl.meta) given_back_inputs; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2650,7 +2650,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) texpression = let vloop_id = loop_id in let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - sanity_check (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta; let rg_id = Option.get rg_id in (* There are two cases depending on the [abs_kind] (whether this is a synth input or a regular loop call) *) @@ -2792,7 +2792,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) | V.SeLiteral _ -> (* We do not *register* symbolic expansions to literal values in the symbolic ADT *) - craise ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | SeMutRef (_, nsv) | SeSharedRef (_, nsv) -> (* The (mut/shared) borrow type is extracted to identity: we thus simply introduce an reassignment *) @@ -2805,11 +2805,11 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) next_e | SeAdt _ -> (* Should be in the [ExpandAdt] case *) - craise ctx.fun_decl.meta "Unreachable") + craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") | ExpandAdt branches -> ( (* We don't do the same thing if there is a branching or not *) match branches with - | [] -> craise ctx.fun_decl.meta "Unreachable" + | [] -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" | [ (variant_id, svl, branch) ] when not (TypesUtils.ty_is_custom_adt sv.V.sv_ty @@ -2848,7 +2848,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) let branch = List.hd branches in let ty = branch.branch.ty in (* Sanity check *) - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun br -> br.branch.ty = ty) branches) ctx.fun_decl.meta; (* Return *) @@ -2870,7 +2870,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) ^ pure_ty_to_string ctx true_e.ty ^ "\n\nfalse_e.ty: " ^ pure_ty_to_string ctx false_e.ty)); - save_error ~b:(ty = false_e.ty) (Some ctx.fun_decl.meta) + save_error __FILE__ __LINE__ ~b:(ty = false_e.ty) (Some ctx.fun_decl.meta) "Internal error, please file an issue"; { e; ty } | ExpandInt (int_ty, branches, otherwise) -> @@ -2896,7 +2896,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) Match all_branches ) in let ty = otherwise.branch.ty in - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) ctx.fun_decl.meta; { e; ty } @@ -3001,7 +3001,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) let var = match vars with | [ v ] -> v - | _ -> craise ctx.fun_decl.meta "Unreachable" + | _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" in (* We simply introduce an assignment - the box type is the * identity when extracted ([box a = a]) *) @@ -3015,7 +3015,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number * of fields!) *) - craise ctx.fun_decl.meta "Attempt to expand a non-expandable value" + craise __FILE__ __LINE__ ctx.fun_decl.meta "Attempt to expand a non-expandable value" and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) (sv : V.symbolic_value) (v : S.value_aggregate) (e : S.expression) @@ -3436,7 +3436,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = in (* Sanity check: all the non-fresh symbolic values are in the context *) - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun (sv : V.symbolic_value) -> V.SymbolicValueId.Map.mem sv.sv_id ctx.sv_to_var) @@ -3461,7 +3461,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* The types shouldn't contain borrows - we can translate them as forward types *) List.map (fun ty -> - cassert + cassert __FILE__ __LINE__ (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)) !ctx.fun_decl.meta "The types shouldn't contain borrows"; ctx_translate_fwd_ty !ctx ty) @@ -3542,7 +3542,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* Add the loop information in the context *) let ctx = - sanity_check (not (LoopId.Map.mem loop_id ctx.loops)) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (not (LoopId.Map.mem loop_id ctx.loops)) ctx.fun_decl.meta; (* Note that we will retrieve the input values later in the [ForwardEnd] (and will introduce the outputs at that moment, together with the actual @@ -3798,7 +3798,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (List.map (pure_ty_to_string ctx) signature.inputs))); (* TODO: we need to normalize the types *) if !Config.type_check_pure_code then - sanity_check + sanity_check __FILE__ __LINE__ (List.for_all (fun (var, ty) -> (var : var).ty = ty) (List.combine inputs signature.inputs)) diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index f7437f7e..74b333f3 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -41,7 +41,7 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (Some (SeLiteral (VBool false)), false_exp); ] -> ExpandBool (true_exp, false_exp) - | _ -> craise meta "Ill-formed boolean expansion") + | _ -> craise __FILE__ __LINE__ meta "Ill-formed boolean expansion") | TLiteral (TInteger int_ty) -> (* Switch over an integer: split between the "regular" branches and the "otherwise" branch (which should be the last branch) *) @@ -51,9 +51,9 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) let get_scalar (see : symbolic_expansion option) : scalar_value = match see with | Some (SeLiteral (VScalar cv)) -> - sanity_check (cv.int_ty = int_ty) meta; + sanity_check __FILE__ __LINE__ (cv.int_ty = int_ty) meta; cv - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in let branches = List.map (fun (see, exp) -> (get_scalar see, exp)) branches @@ -61,7 +61,7 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (* For the otherwise branch, the symbolic value should have been left * unchanged *) let otherwise_see, otherwise = otherwise in - sanity_check (otherwise_see = None) meta; + sanity_check __FILE__ __LINE__ (otherwise_see = None) meta; (* Return *) ExpandInt (int_ty, branches, otherwise) | TAdt (_, _) -> @@ -70,7 +70,7 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) VariantId.id option * symbolic_value list = match see with | Some (SeAdt (vid, fields)) -> (vid, fields) - | _ -> craise meta "Ill-formed branching ADT expansion" + | _ -> craise __FILE__ __LINE__ meta "Ill-formed branching ADT expansion" in let exp = List.map @@ -84,10 +84,10 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (* Reference expansion: there should be one branch *) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) - | _ -> craise meta "Ill-formed borrow expansion") + | _ -> craise __FILE__ __LINE__ meta "Ill-formed borrow expansion") | TVar _ | TLiteral TChar | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> - craise meta "Ill-formed symbolic expansion" + craise __FILE__ __LINE__ meta "Ill-formed symbolic expansion" in Some (Expansion (place, sv, expansion)) @@ -193,7 +193,7 @@ let synthesize_loop (loop_id : LoopId.id) (input_svalues : symbolic_value list) loop_expr; meta; }) - | _ -> craise meta "Unreachable" + | _ -> craise __FILE__ __LINE__ meta "Unreachable" let save_snapshot (ctx : Contexts.eval_ctx) (e : expression option) : expression option = diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 9834fe81..4c0f2e0d 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -176,7 +176,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) SymbolicToPure.fresh_named_vars_for_symbolic_values input_svs ctx in { ctx with forward_inputs } - | _ -> craise fdef.meta "Unreachable" + | _ -> craise __FILE__ __LINE__ fdef.meta "Unreachable" in (* Add the backward inputs *) @@ -447,7 +447,7 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) let global_decls = ctx.trans_ctx.global_ctx.global_decls in let global = GlobalDeclId.Map.find id global_decls in let trans = FunDeclId.Map.find global.body ctx.trans_funs in - sanity_check (trans.loops = []) global.meta; + sanity_check __FILE__ __LINE__ (trans.loops = []) global.meta; let body = trans.f in let is_opaque = Option.is_none body.Pure.body in diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index c4fcdb4a..e6621c7a 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -289,7 +289,7 @@ let analyze_type_decl (updated : bool ref) (infos : type_infos) (List.map (fun v -> List.map (fun f -> f.field_ty) v.fields) variants) - | Opaque -> craise def.meta "unreachable" + | Opaque -> craise __FILE__ __LINE__ def.meta "unreachable" in (* Explore the types and accumulate information *) let type_decl_info = TypeDeclId.Map.find def.def_id infos in diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index d2c48d13..980ebef7 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -12,28 +12,28 @@ let mk_unit_value : typed_value = { value = VAdt { variant_id = None; field_values = [] }; ty = mk_unit_ty } let mk_typed_value (meta : Meta.meta) (ty : ty) (value : value) : typed_value = - sanity_check (ty_is_ety ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_ety ty) meta; { value; ty } let mk_typed_avalue (meta : Meta.meta) (ty : ty) (value : avalue) : typed_avalue = - sanity_check (ty_is_rty ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty ty) meta; { value; ty } let mk_bottom (meta : Meta.meta) (ty : ty) : typed_value = - sanity_check (ty_is_ety ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_ety ty) meta; { value = VBottom; ty } let mk_abottom (meta : Meta.meta) (ty : ty) : typed_avalue = - sanity_check (ty_is_rty ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty ty) meta; { value = ABottom; ty } let mk_aignored (meta : Meta.meta) (ty : ty) : typed_avalue = - sanity_check (ty_is_rty ty) meta; + sanity_check __FILE__ __LINE__ (ty_is_rty ty) meta; { value = AIgnored; ty } let value_as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = - match v with VSymbolic v -> v | _ -> craise meta "Unexpected" + match v with VSymbolic v -> v | _ -> craise __FILE__ __LINE__ meta "Unexpected" (** Box a value *) let mk_box_value (meta : Meta.meta) (v : typed_value) : typed_value = @@ -50,13 +50,13 @@ let is_symbolic (v : value) : bool = match v with VSymbolic _ -> true | _ -> false let as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = - match v with VSymbolic s -> s | _ -> craise meta "Unexpected" + match v with VSymbolic s -> s | _ -> craise __FILE__ __LINE__ meta "Unexpected" let as_mut_borrow (meta : Meta.meta) (v : typed_value) : BorrowId.id * typed_value = match v.value with | VBorrow (VMutBorrow (bid, bv)) -> (bid, bv) - | _ -> craise meta "Unexpected" + | _ -> craise __FILE__ __LINE__ meta "Unexpected" let is_unit (v : typed_value) : bool = ty_is_unit v.ty -- cgit v1.2.3 From 521c7380de5f11bfb190bdccd933ab6c1d0d6ca5 Mon Sep 17 00:00:00 2001 From: Escherichia Date: Fri, 29 Mar 2024 13:50:28 +0100 Subject: added file and line arg to craise, cassert and all related functions --- compiler/ExtractBase.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index eb37a726..8809d0c3 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -254,7 +254,7 @@ let empty_names_map : names_map = (** Small helper to report name collision *) let report_name_collision (id_to_string : id -> string) - ((id1, meta) : id * Meta.meta option) (id2 : id) (name : string) : unit = + (id1 : id) (id2 : id) (name : string) : unit = let id1 = "\n- " ^ id_to_string id1 in let id2 = "\n- " ^ id_to_string id2 in let err = @@ -263,10 +263,10 @@ let report_name_collision (id_to_string : id -> string) ^ "\nYou may want to rename some of your definitions, or report an issue." in (* If we fail hard on errors, raise an exception *) - save_error meta err + save_error __FILE__ __LINE__ None err let names_map_get_id_from_name (name : string) (nm : names_map) : - (id * meta option) option = + id option = StringMap.find_opt name nm.name_to_id let names_map_check_collision (id_to_string : id -> string) (id : id) -- cgit v1.2.3 From 8f969634f3f192a9282a21a1ca2a1b6a676984ca Mon Sep 17 00:00:00 2001 From: Escherichia Date: Fri, 29 Mar 2024 14:07:36 +0100 Subject: formatting and changed save_error condition for failing from b to not b --- compiler/AssociatedTypes.ml | 4 +- compiler/Errors.ml | 48 +++++++++++++------ compiler/Extract.ml | 15 ++++-- compiler/ExtractBase.ml | 7 ++- compiler/ExtractTypes.ml | 9 ++-- compiler/FunsAnalysis.ml | 4 +- compiler/Interpreter.ml | 7 ++- compiler/InterpreterBorrows.ml | 88 ++++++++++++++++++++++++---------- compiler/InterpreterBorrowsCore.ml | 18 +++++-- compiler/InterpreterExpansion.ml | 33 +++++++++---- compiler/InterpreterExpressions.ml | 28 +++++++---- compiler/InterpreterLoops.ml | 3 +- compiler/InterpreterLoopsCore.ml | 4 +- compiler/InterpreterLoopsFixedPoint.ml | 21 +++++--- compiler/InterpreterLoopsJoinCtxs.ml | 23 ++++++--- compiler/InterpreterLoopsMatchCtxs.ml | 80 +++++++++++++++++++++++-------- compiler/InterpreterPaths.ml | 27 +++++++---- compiler/InterpreterProjectors.ml | 10 ++-- compiler/InterpreterStatements.ml | 18 +++++-- compiler/InterpreterUtils.ml | 8 +++- compiler/Invariants.ml | 61 ++++++++++++++++------- compiler/PrePasses.ml | 4 +- compiler/Print.ml | 9 ++-- compiler/PrintPure.ml | 21 +++++--- compiler/PureMicroPasses.ml | 7 ++- compiler/PureTypeCheck.ml | 14 ++++-- compiler/PureUtils.ml | 11 +++-- compiler/SymbolicToPure.ml | 55 +++++++++++++++------ compiler/SynthesizeSymbolic.ml | 4 +- compiler/ValuesUtils.ml | 8 +++- 30 files changed, 468 insertions(+), 181 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 8faaf62b..083a38d1 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -51,7 +51,9 @@ let compute_norm_trait_types_from_preds (meta : Meta.meta option) (* Sanity check: the type constraint can't make use of regions - Remark that it would be enough to only visit the field [ty] of the trait type constraint, but for safety we visit all the fields *) - sanity_check_opt_meta __FILE__ __LINE__ (trait_type_constraint_no_regions c) meta; + sanity_check_opt_meta __FILE__ __LINE__ + (trait_type_constraint_no_regions c) + meta; let { trait_ref; type_name; ty } : trait_type_constraint = c in let trait_ty = TTraitType (trait_ref, type_name) in let trait_ty_ref = get_ref trait_ty in diff --git a/compiler/Errors.ml b/compiler/Errors.ml index bfdf5796..41e841f0 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -13,43 +13,63 @@ exception CFailure of string let error_list : (Meta.meta option * string) list ref = ref [] -let push_error (file : string) (line : int) (meta : Meta.meta option) (msg : string) = - error_list := (meta, msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line) :: !error_list +let push_error (file : string) (line : int) (meta : Meta.meta option) + (msg : string) = + error_list := + (meta, msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line) + :: !error_list -let save_error (file : string) (line : int) ?(b : bool = true) (meta : Meta.meta option) (msg : string) = +let save_error (file : string) (line : int) ?(b : bool = true) + (meta : Meta.meta option) (msg : string) = push_error file line meta msg; match meta with | Some m -> - if !Config.fail_hard && b then - raise (Failure (format_error_message m (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line))) - | None -> if !Config.fail_hard && b then raise (Failure msg) + if !Config.fail_hard && not b then + raise + (Failure + (format_error_message m + (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line))) + | None -> if !Config.fail_hard && not b then raise (Failure msg) -let craise_opt_meta (file : string) (line : int) (meta : Meta.meta option) (msg : string) = +let craise_opt_meta (file : string) (line : int) (meta : Meta.meta option) + (msg : string) = match meta with | Some m -> - if !Config.fail_hard then raise (Failure (format_error_message m (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line))) + if !Config.fail_hard then + raise + (Failure + (format_error_message m + (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line))) else let () = push_error file line (Some m) msg in raise (CFailure msg) | None -> - if !Config.fail_hard then raise (Failure (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line)) + if !Config.fail_hard then + raise + (Failure (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line)) else let () = push_error file line None msg in raise (CFailure msg) -let craise (file : string) (line : int) (meta : Meta.meta) (msg : string) = craise_opt_meta file line (Some meta) msg +let craise (file : string) (line : int) (meta : Meta.meta) (msg : string) = + craise_opt_meta file line (Some meta) msg -let cassert_opt_meta (file : string) (line : int) (b : bool) (meta : Meta.meta option) (msg : string) = +let cassert_opt_meta (file : string) (line : int) (b : bool) + (meta : Meta.meta option) (msg : string) = if not b then craise_opt_meta file line meta msg -let cassert (file : string) (line : int) (b : bool) (meta : Meta.meta) (msg : string) = +let cassert (file : string) (line : int) (b : bool) (meta : Meta.meta) + (msg : string) = cassert_opt_meta file line b (Some meta) msg -let sanity_check (file : string) (line : int) b meta = cassert file line b meta "Internal error, please file an issue" +let sanity_check (file : string) (line : int) b meta = + cassert file line b meta "Internal error, please file an issue" let sanity_check_opt_meta (file : string) (line : int) b meta = cassert_opt_meta file line b meta "Internal error, please file an issue" -let internal_error (file : string) (line : int) meta = craise file line meta "Internal error, please report an issue" +let internal_error (file : string) (line : int) meta = + craise file line meta "Internal error, please report an issue" + let exec_raise = craise let exec_assert = cassert diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 4fb0e3c8..1a9b3baa 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -281,7 +281,9 @@ let lets_require_wrap_in_do (meta : Meta.meta) (* HOL4 is similar to HOL4, but we add a sanity check *) let wrap_in_do = List.exists (fun (m, _, _) -> m) lets in if wrap_in_do then - sanity_check __FILE__ __LINE__ (List.for_all (fun (m, _, _) -> m) lets) meta; + sanity_check __FILE__ __LINE__ + (List.for_all (fun (m, _, _) -> m) lets) + meta; wrap_in_do | FStar | Coq -> false @@ -485,7 +487,9 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) F.pp_print_string fmt fun_name); (* Sanity check: HOL4 doesn't support const generics *) - sanity_check __FILE__ __LINE__ (generics.const_generics = [] || !backend <> HOL4) meta; + sanity_check __FILE__ __LINE__ + (generics.const_generics = [] || !backend <> HOL4) + meta; (* Print the generics. We might need to filter some of the type arguments, if the type @@ -1872,8 +1876,11 @@ let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : global_decl) (body : fun_decl) (interface : bool) : unit = let meta = body.meta in - cassert __FILE__ __LINE__ body.is_global_decl_body body.meta "TODO: Error message"; - cassert __FILE__ __LINE__ (body.signature.inputs = []) body.meta "TODO: Error message"; + cassert __FILE__ __LINE__ body.is_global_decl_body body.meta + "TODO: Error message"; + cassert __FILE__ __LINE__ + (body.signature.inputs = []) + body.meta "TODO: Error message"; (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 8809d0c3..74ac9e32 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -253,8 +253,8 @@ let empty_names_map : names_map = } (** Small helper to report name collision *) -let report_name_collision (id_to_string : id -> string) - (id1 : id) (id2 : id) (name : string) : unit = +let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) + (name : string) : unit = let id1 = "\n- " ^ id_to_string id1 in let id2 = "\n- " ^ id_to_string id2 in let err = @@ -265,8 +265,7 @@ let report_name_collision (id_to_string : id -> string) (* If we fail hard on errors, raise an exception *) save_error __FILE__ __LINE__ None err -let names_map_get_id_from_name (name : string) (nm : names_map) : - id option = +let names_map_get_id_from_name (name : string) (nm : names_map) : id option = StringMap.find_opt name nm.name_to_id let names_map_check_collision (id_to_string : id -> string) (id : id) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index f737f73b..6dbf528c 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -148,7 +148,8 @@ let extract_unop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) (cast_str, None, Some tgt) | TInteger _, TBool -> (* This is not allowed by rustc: the way of doing it in Rust is: [x != 0] *) - craise __FILE__ __LINE__ meta "Unexpected cast: integer to bool" + craise __FILE__ __LINE__ meta + "Unexpected cast: integer to bool" | TBool, TBool -> (* There shouldn't be any cast here. Note that if one writes [b as bool] in Rust (where [b] is a @@ -534,7 +535,8 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) extract_rec false ret_ty; if inside then F.pp_print_string fmt ")" | TTraitType (trait_ref, type_name) -> ( - if !parameterize_trait_types then craise __FILE__ __LINE__ meta "Unimplemented" + if !parameterize_trait_types then + craise __FILE__ __LINE__ meta "Unimplemented" else let type_name = ctx_get_trait_type meta trait_ref.trait_decl_ref.trait_decl_id @@ -818,7 +820,8 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : (fun variant_id (variant : variant) -> (variant_id, StringMap.find variant.variant_name variant_map)) variants - | _ -> craise __FILE__ __LINE__ def.meta "Invalid builtin information" + | _ -> + craise __FILE__ __LINE__ def.meta "Invalid builtin information" in List.fold_left (fun ctx (vid, vname) -> diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index df2a010d..cad469f9 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -145,7 +145,9 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) end in (* Sanity check: global bodies don't contain stateful calls *) - sanity_check __FILE__ __LINE__ ((not f.is_global_decl_body) || not !stateful) f.meta; + sanity_check __FILE__ __LINE__ + ((not f.is_global_decl_body) || not !stateful) + f.meta; let builtin_info = get_builtin_info f in let has_builtin_info = builtin_info <> None in group_has_builtin_info := !group_has_builtin_info || has_builtin_info; diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index ea1d5633..a65e1663 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -435,7 +435,8 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) else abs | Loop (loop_id', _, LoopCall) -> (* We can end all the loop call abstractions *) - sanity_check __FILE__ __LINE__ (loop_id = Some loop_id') fdef.meta; + sanity_check __FILE__ __LINE__ (loop_id = Some loop_id') + fdef.meta; { abs with can_end = true } | SynthInput rg_id' -> if rg_id' = back_id && end_fun_synth_input then @@ -636,7 +637,9 @@ module Test = struct fdef.name)); (* Sanity check - *) - sanity_check __FILE__ __LINE__ (fdef.signature.generics = empty_generic_params) fdef.meta; + sanity_check __FILE__ __LINE__ + (fdef.signature.generics = empty_generic_params) + fdef.meta; sanity_check __FILE__ __LINE__ (body.arg_count = 0) fdef.meta; (* Create the evaluation context *) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index cc34020a..b32261e6 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -308,7 +308,8 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) ("give_back_value: improper type:\n- expected: " ^ ty_to_string ctx ty ^ "\n- received: " ^ ty_to_string ctx nv.ty); - craise __FILE__ __LINE__ meta "Value given back doesn't have the proper type"); + craise __FILE__ __LINE__ meta + "Value given back doesn't have the proper type"); (* Replace *) set_replaced (); nv.value) @@ -442,7 +443,8 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - cassert __FILE__ __LINE__ !replaced meta "Only one loan should have been given back"; + cassert __FILE__ __LINE__ !replaced meta + "Only one loan should have been given back"; (* Apply the reborrows *) apply_registered_reborrows ctx @@ -451,7 +453,9 @@ let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) - sanity_check __FILE__ __LINE__ (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) meta; + sanity_check __FILE__ __LINE__ + (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) + meta; (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in (* Substitution function, to replace the borrow projectors over symbolic values *) @@ -498,7 +502,8 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - cassert __FILE__ __LINE__ (not !replaced) meta "Only one loan should have been updated"; + cassert __FILE__ __LINE__ (not !replaced) meta + "Only one loan should have been updated"; replaced := true in let obj = @@ -541,7 +546,8 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) ("give_back_avalue_to_same_abstraction: improper type:\n\ - expected: " ^ ty_to_string ctx ty ^ "\n- received: " ^ ty_to_string ctx nv.ty); - craise __FILE__ __LINE__ meta "Value given back doesn't have the proper type"); + craise __FILE__ __LINE__ meta + "Value given back doesn't have the proper type"); (* This is the loan we are looking for: apply the projection to * the value we give back and replaced this mutable loan with * an ended loan *) @@ -601,7 +607,8 @@ let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = - cassert __FILE__ __LINE__ (not !replaced) meta "Only one loan should be updated"; + cassert __FILE__ __LINE__ (not !replaced) meta + "Only one loan should be updated"; replaced := true in let obj = @@ -666,7 +673,8 @@ let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - cassert __FILE__ __LINE__ !replaced meta "Exactly one loan should be given back"; + cassert __FILE__ __LINE__ !replaced meta + "Exactly one loan should be given back"; (* Return *) ctx @@ -773,21 +781,27 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) sanity_check __FILE__ __LINE__ (l' = l) meta; sanity_check __FILE__ __LINE__ (not (loans_in_value tv)) meta; (* Check that the corresponding loan is somewhere - purely a sanity check *) - sanity_check __FILE__ __LINE__ (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; + sanity_check __FILE__ __LINE__ + (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) + meta; (* Update the context *) give_back_value config meta l tv ctx | Concrete (VSharedBorrow l' | VReservedMutBorrow l') -> (* Sanity check *) sanity_check __FILE__ __LINE__ (l' = l) meta; (* Check that the borrow is somewhere - purely a sanity check *) - sanity_check __FILE__ __LINE__ (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; + sanity_check __FILE__ __LINE__ + (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) + meta; (* Update the context *) give_back_shared config meta l ctx | Abstract (AMutBorrow (l', av)) -> (* Sanity check *) sanity_check __FILE__ __LINE__ (l' = l) meta; (* Check that the corresponding loan is somewhere - purely a sanity check *) - sanity_check __FILE__ __LINE__ (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; + sanity_check __FILE__ __LINE__ + (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) + meta; (* Convert the avalue to a (fresh symbolic) value. Rem.: we shouldn't do this here. We should do this in a function @@ -802,7 +816,9 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (* Sanity check *) sanity_check __FILE__ __LINE__ (l' = l) meta; (* Check that the borrow is somewhere - purely a sanity check *) - sanity_check __FILE__ __LINE__ (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) meta; + sanity_check __FILE__ __LINE__ + (Option.is_some (lookup_loan_opt meta sanity_ek l ctx)) + meta; (* Update the context *) give_back_shared config meta l ctx | Abstract (AProjSharedBorrow asb) -> @@ -946,7 +962,9 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (* Sanity check: the borrowed value shouldn't contain loans *) (match bc with | Concrete (VMutBorrow (_, bv)) -> - sanity_check __FILE__ __LINE__ (Option.is_none (get_first_loan_in_value bv)) meta + sanity_check __FILE__ __LINE__ + (Option.is_none (get_first_loan_in_value bv)) + meta | _ -> ()); (* Give back the value *) let ctx = give_back config meta l bc ctx in @@ -1602,7 +1620,9 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) ("activate_reserved_mut_borrow: resulting value:\n" ^ typed_value_to_string ~meta:(Some meta) ctx sv)); sanity_check __FILE__ __LINE__ (not (loans_in_value sv)) meta; - sanity_check __FILE__ __LINE__ (not (bottom_in_value ctx.ended_regions sv)) meta; + sanity_check __FILE__ __LINE__ + (not (bottom_in_value ctx.ended_regions sv)) + meta; sanity_check __FILE__ __LINE__ (not (reserved_in_value sv)) meta; (* End the borrows which borrow from the value, at the exception of the borrow we want to promote *) @@ -1737,7 +1757,8 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) list_avalues false push_fail child_av | AProjSharedBorrow asb -> (* We don't support nested borrows *) - cassert __FILE__ __LINE__ (asb = []) meta "Nested borrows are not supported yet"; + cassert __FILE__ __LINE__ (asb = []) meta + "Nested borrows are not supported yet"; (* Nothing specific to do *) () | AEndedMutBorrow _ | AEndedSharedBorrow -> @@ -1749,7 +1770,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) | ASymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) - sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta + sanity_check __FILE__ __LINE__ + (not (ty_has_borrows ctx.type_ctx.type_infos ty)) + meta and list_values (v : typed_value) : typed_avalue list * typed_value = let ty = v.ty in match v.value with @@ -1803,7 +1826,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) | VSymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) - sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos ty)) meta; + sanity_check __FILE__ __LINE__ + (not (ty_has_borrows ctx.type_ctx.type_infos ty)) + meta; ([], v) in @@ -2033,7 +2058,9 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) loans := BorrowId.Set.union !loans ids; BorrowId.Set.iter (fun id -> - sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem id !loan_to_content)) meta; + sanity_check __FILE__ __LINE__ + (not (BorrowId.Map.mem id !loan_to_content)) + meta; loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans) ids @@ -2041,14 +2068,18 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) let push_loan id (lc : g_loan_content_with_ty) : unit = sanity_check __FILE__ __LINE__ (not (BorrowId.Set.mem id !loans)) meta; loans := BorrowId.Set.add id !loans; - sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem id !loan_to_content)) meta; + sanity_check __FILE__ __LINE__ + (not (BorrowId.Map.mem id !loan_to_content)) + meta; loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans in let push_borrow id (bc : g_borrow_content_with_ty) : unit = sanity_check __FILE__ __LINE__ (not (BorrowId.Set.mem id !borrows)) meta; borrows := BorrowId.Set.add id !borrows; - sanity_check __FILE__ __LINE__ (not (BorrowId.Map.mem id !borrow_to_content)) meta; + sanity_check __FILE__ __LINE__ + (not (BorrowId.Map.mem id !borrow_to_content)) + meta; borrow_to_content := BorrowId.Map.add id bc !borrow_to_content; borrows_loans := BorrowId id :: !borrows_loans in @@ -2129,7 +2160,9 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) method! visit_symbolic_value _ sv = (* Sanity check: no borrows *) - sanity_check __FILE__ __LINE__ (not (symbolic_value_has_borrows ctx sv)) meta + sanity_check __FILE__ __LINE__ + (not (symbolic_value_has_borrows ctx sv)) + meta end in @@ -2240,7 +2273,9 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) if merge_funs = None then - (sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint borrows0 borrows1) meta; + (sanity_check __FILE__ __LINE__ + (BorrowId.Set.disjoint borrows0 borrows1) + meta; sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint loans0 loans1)) meta; @@ -2358,8 +2393,12 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) to preserve (in practice it works because we destructure the shared values in the abstractions, and forbid nested borrows). *) - sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv0.value)) meta; - sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv0.value)) meta; + sanity_check __FILE__ __LINE__ + (not (value_has_loans_or_borrows ctx sv0.value)) + meta; + sanity_check __FILE__ __LINE__ + (not (value_has_loans_or_borrows ctx sv0.value)) + meta; sanity_check __FILE__ __LINE__ (is_aignored child0.value) meta; sanity_check __FILE__ __LINE__ (is_aignored child1.value) meta; None) @@ -2476,7 +2515,8 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) sanity_check __FILE__ __LINE__ (not (BorrowId.Set.is_empty bids)) meta; - sanity_check __FILE__ __LINE__ (is_aignored child.value) meta; + sanity_check __FILE__ __LINE__ + (is_aignored child.value) meta; sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv.value)) meta; diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index fd656063..92d8670a 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -110,7 +110,9 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) sanity_check __FILE__ __LINE__ (id1 = id2) meta; (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) - sanity_check __FILE__ __LINE__ (generics1.const_generics = generics2.const_generics) meta; + sanity_check __FILE__ __LINE__ + (generics1.const_generics = generics2.const_generics) + meta; (* We also ignore the trait refs *) @@ -805,7 +807,9 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) let set_non_shared () = match !shared with | None -> shared := Some false - | Some _ -> craise __FILE__ __LINE__ meta "Found unexpected intersecting proj_borrows" + | Some _ -> + craise __FILE__ __LINE__ meta + "Found unexpected intersecting proj_borrows" in let check_proj_borrows is_shared abs sv' proj_ty = if @@ -825,7 +829,9 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) method! visit_abstract_shared_borrows abs asb = (* Sanity check *) - (match !shared with Some b -> sanity_check __FILE__ __LINE__ b meta | _ -> ()); + (match !shared with + | Some b -> sanity_check __FILE__ __LINE__ b meta + | _ -> ()); (* Explore *) if can_update_shared then let abs = Option.get abs in @@ -857,7 +863,8 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (* Apply *) let ctx = obj#visit_eval_ctx None ctx in (* Check that we updated the context at least once *) - cassert __FILE__ __LINE__ (Option.is_some !shared) meta "Context was not updated at least once"; + cassert __FILE__ __LINE__ (Option.is_some !shared) meta + "Context was not updated at least once"; (* Return *) ctx @@ -1156,7 +1163,8 @@ let no_aproj_over_symbolic_in_context (meta : Meta.meta) (sv : symbolic_value) in (* Apply *) try obj#visit_eval_ctx () ctx - with Found -> craise __FILE__ __LINE__ meta "update_aproj_loans_to_ended: failed" + with Found -> + craise __FILE__ __LINE__ meta "update_aproj_loans_to_ended: failed" (** Helper function diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 0b7c071e..e47fbfbe 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -78,7 +78,9 @@ let apply_symbolic_expansion_to_target_avalues (config : config) method! visit_aproj current_abs aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - sanity_check __FILE__ __LINE__ (not (same_symbolic_id sv original_sv)) meta + sanity_check __FILE__ __LINE__ + (not (same_symbolic_id sv original_sv)) + meta | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj current_abs aproj @@ -228,7 +230,8 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) in (* Check if there is strictly more than one variant *) if List.length variants_fields_types > 1 && not expand_enumerations then - craise __FILE__ __LINE__ meta "Not allowed to expand enumerations with several variants"; + craise __FILE__ __LINE__ meta + "Not allowed to expand enumerations with several variants"; (* Initialize the expanded value for a given variant *) let initialize ((variant_id, field_types) : VariantId.id option * rty list) : symbolic_expansion = @@ -279,7 +282,8 @@ let compute_expanded_symbolic_adt_value (meta : Meta.meta) | TAssumed TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value meta boxed_ty ] | _ -> - craise __FILE__ __LINE__ meta "compute_expanded_symbolic_adt_value: unexpected combination" + craise __FILE__ __LINE__ meta + "compute_expanded_symbolic_adt_value: unexpected combination" let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) @@ -356,7 +360,9 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) method! visit_aproj proj_regions aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - sanity_check __FILE__ __LINE__ (not (same_symbolic_id sv original_sv)) meta + sanity_check __FILE__ __LINE__ + (not (same_symbolic_id sv original_sv)) + meta | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj proj_regions aproj @@ -402,7 +408,9 @@ let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) fun cf ctx -> sanity_check __FILE__ __LINE__ (region <> RErased) meta; (* Check that we are allowed to expand the reference *) - sanity_check __FILE__ __LINE__ (not (region_in_set region ctx.ended_regions)) meta; + sanity_check __FILE__ __LINE__ + (not (region_in_set region ctx.ended_regions)) + meta; (* Match on the reference kind *) match rkind with | RMut -> @@ -490,7 +498,9 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) match resl with | Some _ :: _ -> Some (List.map Option.get resl) | None :: _ -> - List.iter (fun res -> sanity_check __FILE__ __LINE__ (res = None) meta) resl; + List.iter + (fun res -> sanity_check __FILE__ __LINE__ (res = None) meta) + resl; None | _ -> craise __FILE__ __LINE__ meta "Unreachable" in @@ -573,7 +583,9 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); (* Sanity check: the symbolic value has disappeared *) - sanity_check __FILE__ __LINE__ (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta) + sanity_check __FILE__ __LINE__ + (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) + meta) in (* Continue *) cc cf ctx @@ -603,7 +615,9 @@ let expand_symbolic_adt (config : config) (meta : Meta.meta) let seel = List.map (fun see -> (Some see, cf_branches)) seel in apply_branching_symbolic_expansions_non_borrow config meta original_sv original_sv_place seel cf_after_join ctx - | _ -> craise __FILE__ __LINE__ meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) + | _ -> + craise __FILE__ __LINE__ meta + ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) let expand_symbolic_int (config : config) (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) @@ -684,7 +698,8 @@ let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : of [config]): " ^ name_to_string ctx def.name) | Opaque -> - craise __FILE__ __LINE__ meta "Attempted to greedily expand an opaque type"); + craise __FILE__ __LINE__ meta + "Attempted to greedily expand an opaque type"); (* Also, we need to check if the definition is recursive *) if ctx_type_decl_is_rec ctx def_id then craise __FILE__ __LINE__ meta diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 59f74ad8..d61ba410 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -142,9 +142,12 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) (* Sanity check *) (match v.ty with | TAdt (TAssumed TBox, _) -> - exec_raise __FILE__ __LINE__ meta "Can't copy an assumed value other than Option" + exec_raise __FILE__ __LINE__ meta + "Can't copy an assumed value other than Option" | TAdt (TAdtId _, _) as ty -> - sanity_check __FILE__ __LINE__ (allow_adt_copy || ty_is_primitively_copyable ty) meta + sanity_check __FILE__ __LINE__ + (allow_adt_copy || ty_is_primitively_copyable ty) + meta | TAdt (TTuple, _) -> () (* Ok *) | TAdt ( TAssumed (TSlice | TArray), @@ -174,13 +177,15 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) let bid' = fresh_borrow_id () in let ctx = InterpreterBorrows.reborrow_shared meta bid bid' ctx in (ctx, { v with value = VBorrow (VSharedBorrow bid') }) - | VMutBorrow (_, _) -> exec_raise __FILE__ __LINE__ meta "Can't copy a mutable borrow" + | VMutBorrow (_, _) -> + exec_raise __FILE__ __LINE__ meta "Can't copy a mutable borrow" | VReservedMutBorrow _ -> exec_raise __FILE__ __LINE__ meta "Can't copy a reserved mut borrow") | VLoan lc -> ( (* We can only copy shared loans *) match lc with - | VMutLoan _ -> exec_raise __FILE__ __LINE__ meta "Can't copy a mutable loan" + | VMutLoan _ -> + exec_raise __FILE__ __LINE__ meta "Can't copy a mutable loan" | VSharedLoan (_, sv) -> (* We don't copy the shared loan: only the shared value inside *) copy_value meta allow_adt_copy config ctx sv) @@ -420,7 +425,9 @@ let eval_two_operands (config : config) (meta : Meta.meta) (op1 : operand) (op2 : operand) (cf : typed_value * typed_value -> m_fun) : m_fun = let eval_op = eval_operands config meta [ op1; op2 ] in let use_res cf res = - match res with [ v1; v2 ] -> cf (v1, v2) | _ -> craise __FILE__ __LINE__ meta "Unreachable" + match res with + | [ v1; v2 ] -> cf (v1, v2) + | _ -> craise __FILE__ __LINE__ meta "Unreachable" in comp eval_op use_res cf @@ -463,7 +470,9 @@ let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) let b = if Z.of_int 0 = sv.value then false else if Z.of_int 1 = sv.value then true - else exec_raise __FILE__ __LINE__ meta "Conversion from int to bool: out of range" + else + exec_raise __FILE__ __LINE__ meta + "Conversion from int to bool: out of range" in let value = VLiteral (VBool b) in let ty = TLiteral TBool in @@ -793,7 +802,9 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) meta; (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in - sanity_check __FILE__ __LINE__ (len = Z.of_int (List.length values)) meta; + sanity_check __FILE__ __LINE__ + (len = Z.of_int (List.length values)) + meta; let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in let ty = TAdt (TAssumed TArray, generics) in (* In order to generate a better AST, we introduce a symbolic @@ -809,7 +820,8 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (* Introduce the symbolic value in the AST *) let sv = ValuesUtils.value_as_symbolic meta saggregated.value in Some (SymbolicAst.IntroSymbolic (ctx, None, sv, VaArray values, e))) - | AggregatedClosure _ -> craise __FILE__ __LINE__ meta "Closures are not supported yet" + | AggregatedClosure _ -> + craise __FILE__ __LINE__ meta "Closures are not supported yet" in (* Compose and apply *) comp eval_ops compute cf diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 17487401..e4370367 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -160,7 +160,8 @@ let eval_loop_symbolic (config : config) (meta : meta) cf res ctx | Continue i -> (* We don't support nested loops for now *) - cassert __FILE__ __LINE__ (i = 0) meta "Nested loops are not supported yet"; + cassert __FILE__ __LINE__ (i = 0) meta + "Nested loops are not supported yet"; log#ldebug (lazy ("eval_loop_symbolic: about to match the fixed-point context \ diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index a8a64264..2283e842 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -380,7 +380,9 @@ let ctx_split_fixed_new (meta : Meta.meta) (fixed_ids : ids_sets) let new_absl = List.map (fun ee -> - match ee with EAbs abs -> abs | _ -> craise __FILE__ __LINE__ meta "Unreachable") + match ee with + | EAbs abs -> abs + | _ -> craise __FILE__ __LINE__ meta "Unreachable") new_absl in let new_dummyl = diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 39add08e..9ff2fe38 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -270,10 +270,13 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : (* Rem.: the below sanity checks are not really necessary *) sanity_check __FILE__ __LINE__ (AbstractionId.Set.is_empty abs.parents) meta; sanity_check __FILE__ __LINE__ (abs.original_parents = []) meta; - sanity_check __FILE__ __LINE__ (RegionId.Set.is_empty abs.ancestors_regions) meta; + sanity_check __FILE__ __LINE__ + (RegionId.Set.is_empty abs.ancestors_regions) + meta; (* Introduce the new abstraction for the shared values *) - cassert __FILE__ __LINE__ (ty_no_regions sv.ty) meta "Nested borrows are not supported yet"; + cassert __FILE__ __LINE__ (ty_no_regions sv.ty) meta + "Nested borrows are not supported yet"; let rty = sv.ty in (* Create the shared loan child *) @@ -481,7 +484,8 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) craise __FILE__ __LINE__ meta "Unreachable" | Continue i -> (* For now we don't support continues to outer loops *) - cassert __FILE__ __LINE__ (i = 0) meta "Continues to outer loops not supported yet"; + cassert __FILE__ __LINE__ (i = 0) meta + "Continues to outer loops not supported yet"; register_ctx ctx; None | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> @@ -736,7 +740,9 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (* We also check that all the regions need to end - this is not necessary per se, but if it doesn't happen it is bizarre and worth investigating... *) - sanity_check __FILE__ __LINE__ (AbstractionId.Set.equal !aids_union !fp_aids) meta; + sanity_check __FILE__ __LINE__ + (AbstractionId.Set.equal !aids_union !fp_aids) + meta; (* Merge the abstractions which need to be merged, and compute the map from region id to abstraction id *) @@ -794,7 +800,8 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) fp := fp'; id0 := id0'; () - with ValueMatchFailure _ -> craise __FILE__ __LINE__ meta "Unexpected") + with ValueMatchFailure _ -> + craise __FILE__ __LINE__ meta "Unexpected") ids; (* Register the mapping *) let abs = ctx_lookup_abs !fp !id0 in @@ -957,7 +964,9 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) ids.loan_ids in (* Check that the loan and borrows are related *) - sanity_check __FILE__ __LINE__ (BorrowId.Set.equal ids.borrow_ids loan_ids) meta) + sanity_check __FILE__ __LINE__ + (BorrowId.Set.equal ids.borrow_ids loan_ids) + meta) new_absl; (* For every target abstraction (going back to the [list_nth_mut] example, diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 3b1767e8..d97b05d0 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -335,8 +335,12 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) let _ = let _, ty0, _ = ty_as_ref ty0 in let _, ty1, _ = ty_as_ref ty1 in - sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) meta; - sanity_check __FILE__ __LINE__ (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) meta + sanity_check __FILE__ __LINE__ + (not (ty_has_borrows ctx.type_ctx.type_infos ty0)) + meta; + sanity_check __FILE__ __LINE__ + (not (ty_has_borrows ctx.type_ctx.type_infos ty1)) + meta in (* Same remarks as for [merge_amut_borrows] *) @@ -365,8 +369,12 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) This time we need to also merge the shared values. We rely on the join matcher [JM] to do so. *) - sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv0.value)) meta; - sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv1.value)) meta; + sanity_check __FILE__ __LINE__ + (not (value_has_loans_or_borrows ctx sv0.value)) + meta; + sanity_check __FILE__ __LINE__ + (not (value_has_loans_or_borrows ctx sv1.value)) + meta; let ty = ty0 in let child = child0 in let sv = M.match_typed_values ctx ctx sv0 sv1 in @@ -437,7 +445,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (* Variables are necessarily in the prefix *) craise __FILE__ __LINE__ meta "Unreachable" | EBinding (BDummy did, _) -> - sanity_check __FILE__ __LINE__ (not (DummyVarId.Set.mem did fixed_ids.dids)) meta + sanity_check __FILE__ __LINE__ + (not (DummyVarId.Set.mem did fixed_ids.dids)) + meta | EAbs abs -> sanity_check __FILE__ __LINE__ (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) @@ -527,7 +537,8 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (* Same as for the dummy values: there are two cases *) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( (* Still in the prefix: the abstractions must be the same *) - cassert __FILE__ __LINE__ (abs0 = abs1) meta "The abstractions are not the same"; + cassert __FILE__ __LINE__ (abs0 = abs1) meta + "The abstractions are not the same"; (* Continue *) abs :: join_prefixes env0' env1') else (* Not in the prefix anymore *) diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 9c017f19..6d814c5c 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -96,7 +96,8 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) | AIgnoredSharedLoan child -> (* Ignore the id of the loan, if there is *) self#visit_typed_avalue abs_id child - | AEndedMutLoan _ | AEndedSharedLoan _ -> craise __FILE__ __LINE__ meta "Unreachable" + | AEndedMutLoan _ | AEndedSharedLoan _ -> + craise __FILE__ __LINE__ meta "Unreachable" (** Make sure we don't register the ignored ids *) method! visit_aborrow_content abs_id bc = @@ -109,7 +110,8 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) -> (* Ignore the id of the borrow, if there is *) self#visit_typed_avalue abs_id child - | AEndedMutBorrow _ | AEndedSharedBorrow -> craise __FILE__ __LINE__ meta "Unreachable" + | AEndedMutBorrow _ | AEndedSharedBorrow -> + craise __FILE__ __LINE__ meta "Unreachable" method! visit_borrow_id abs_id bid = register_borrow_id abs_id bid method! visit_loan_id abs_id lid = register_loan_id abs_id lid @@ -151,8 +153,12 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) match (ty0, ty1) with | TAdt (id0, generics0), TAdt (id1, generics1) -> sanity_check __FILE__ __LINE__ (id0 = id1) meta; - sanity_check __FILE__ __LINE__ (generics0.const_generics = generics1.const_generics) meta; - sanity_check __FILE__ __LINE__ (generics0.trait_refs = generics1.trait_refs) meta; + sanity_check __FILE__ __LINE__ + (generics0.const_generics = generics1.const_generics) + meta; + sanity_check __FILE__ __LINE__ + (generics0.trait_refs = generics1.trait_refs) + meta; let id = id0 in let const_generics = generics1.const_generics in let trait_refs = generics1.trait_refs in @@ -213,8 +219,12 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct { value; ty = v1.ty } else ( (* For now, we don't merge ADTs which contain borrows *) - sanity_check __FILE__ __LINE__ (not (value_has_borrows v0.value)) M.meta; - sanity_check __FILE__ __LINE__ (not (value_has_borrows v1.value)) M.meta; + sanity_check __FILE__ __LINE__ + (not (value_has_borrows v0.value)) + M.meta; + sanity_check __FILE__ __LINE__ + (not (value_has_borrows v1.value)) + M.meta; (* Merge *) M.match_distinct_adts ctx0 ctx1 ty av0 av1) | VBottom, VBottom -> v0 @@ -387,7 +397,9 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct log#ldebug (lazy "match_typed_avalues: shared loans"); let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in - sanity_check __FILE__ __LINE__ (not (value_has_borrows sv.value)) M.meta; + sanity_check __FILE__ __LINE__ + (not (value_has_borrows sv.value)) + M.meta; M.match_ashared_loans ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 av1 ty sv av | AMutLoan (id0, av0), AMutLoan (id1, av1) -> @@ -795,11 +807,21 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) - let match_distinct_aadts _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" - let match_ashared_borrows _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" - let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" - let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_distinct_aadts _ _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + + let match_ashared_borrows _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + + let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + + let match_amut_loans _ _ _ _ _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + let match_avalues _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" end @@ -917,11 +939,21 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) - let match_distinct_aadts _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" - let match_ashared_borrows _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" - let match_amut_borrows _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" - let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" + let match_distinct_aadts _ _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + + let match_ashared_borrows _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + + let match_amut_borrows _ _ _ _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + + let match_amut_loans _ _ _ _ _ _ _ _ _ _ = + craise __FILE__ __LINE__ meta "Unreachable" + let match_avalues _ _ _ _ = craise __FILE__ __LINE__ meta "Unreachable" end @@ -1129,7 +1161,9 @@ struct sanity_check __FILE__ __LINE__ left meta; let id = sv.sv_id in (* Check: fixed values are fixed *) - sanity_check __FILE__ __LINE__ (not (SymbolicValueId.InjSubst.mem id !S.sid_map)) meta; + sanity_check __FILE__ __LINE__ + (not (SymbolicValueId.InjSubst.mem id !S.sid_map)) + meta; (* Update the binding for the target symbolic value *) S.sid_to_value_map := SymbolicValueId.Map.add_strict id v !S.sid_to_value_map; @@ -1355,7 +1389,8 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) sanity_check __FILE__ __LINE__ (v0 = v1) meta; (* The ids present in the left value must be fixed *) let ids, _ = compute_typed_value_ids v0 in - sanity_check __FILE__ __LINE__ ((not S.check_equiv) || ids_are_fixed ids)) + sanity_check __FILE__ __LINE__ + ((not S.check_equiv) || ids_are_fixed ids)) meta; (* We still match the values - allows to compute mappings (which are the identity actually) *) @@ -1376,7 +1411,9 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) sanity_check __FILE__ __LINE__ (abs0 = abs1) meta; (* Their ids must be fixed *) let ids, _ = compute_abs_ids abs0 in - sanity_check __FILE__ __LINE__ ((not S.check_equiv) || ids_are_fixed ids) meta; + sanity_check __FILE__ __LINE__ + ((not S.check_equiv) || ids_are_fixed ids) + meta; (* Continue *) match_envs env0' env1') else ( @@ -1765,7 +1802,8 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) abstractions and in the *variable bindings* once we allow symbolic values containing borrows to not be eagerly expanded. *) - sanity_check __FILE__ __LINE__ Config.greedy_expand_symbolics_with_borrows meta; + sanity_check __FILE__ __LINE__ Config.greedy_expand_symbolics_with_borrows + meta; (* Update the borrows and loans in the abstractions of the target context. diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 26456acf..93e56106 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -101,7 +101,9 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (match (proj_kind, type_id) with | ProjAdt (def_id, opt_variant_id), TAdtId def_id' -> sanity_check __FILE__ __LINE__ (def_id = def_id') meta; - sanity_check __FILE__ __LINE__ (opt_variant_id = adt.variant_id) meta + sanity_check __FILE__ __LINE__ + (opt_variant_id = adt.variant_id) + meta | _ -> craise __FILE__ __LINE__ meta "Unreachable"); (* Actually project *) let fv = FieldId.nth adt.field_values field_id in @@ -117,7 +119,9 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) Ok (ctx, { res with updated })) (* Tuples *) | Field (ProjTuple arity, field_id), VAdt adt, TAdt (TTuple, _) -> ( - sanity_check __FILE__ __LINE__ (arity = List.length adt.field_values) meta; + sanity_check __FILE__ __LINE__ + (arity = List.length adt.field_values) + meta; let fv = FieldId.nth adt.field_values field_id in (* Project *) match access_projection meta access ctx update p' fv with @@ -191,7 +195,8 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } | AIgnoredSharedLoan _ ) ) -> - craise __FILE__ __LINE__ meta "Expected a shared (abstraction) loan" + craise __FILE__ __LINE__ meta + "Expected a shared (abstraction) loan" | _, Abstract (ASharedLoan (bids, sv, _av)) -> ( (* Explore the shared value *) match access_projection meta access ctx update p' sv with @@ -327,7 +332,8 @@ let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) let read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value = match try_read_place meta access p ctx with - | Error e -> craise __FILE__ __LINE__ meta ("Unreachable: " ^ show_path_fail_kind e) + | Error e -> + craise __FILE__ __LINE__ meta ("Unreachable: " ^ show_path_fail_kind e) | Ok v -> v (** Attempt to update the value at a given place *) @@ -345,13 +351,16 @@ let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) let write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : typed_value) (ctx : eval_ctx) : eval_ctx = match try_write_place meta access p nv ctx with - | Error e -> craise __FILE__ __LINE__ meta ("Unreachable: " ^ show_path_fail_kind e) + | Error e -> + craise __FILE__ __LINE__ meta ("Unreachable: " ^ show_path_fail_kind e) | Ok ctx -> ctx let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) (generics : generic_args) : typed_value = - sanity_check __FILE__ __LINE__ (TypesUtils.generic_args_only_erased_regions generics) meta; + sanity_check __FILE__ __LINE__ + (TypesUtils.generic_args_only_erased_regions generics) + meta; (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list @@ -475,7 +484,8 @@ let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) | FailBottom (_, _, _) -> (* We can't expand {!Bottom} values while reading them *) craise __FILE__ __LINE__ meta "Found [Bottom] while reading a place" - | FailBorrow _ -> craise __FILE__ __LINE__ meta "Could not read a borrow" + | FailBorrow _ -> + craise __FILE__ __LINE__ meta "Could not read a borrow" in comp cc (update_ctx_along_read_place config meta access p) cf ctx @@ -506,7 +516,8 @@ let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) pe ty ctx in cf ctx - | FailBorrow _ -> craise __FILE__ __LINE__ meta "Could not write to a borrow" + | FailBorrow _ -> + craise __FILE__ __LINE__ meta "Could not write to a borrow" in (* Retry *) comp cc (update_ctx_along_write_place config meta access p) cf ctx diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 0421a46c..d7c20ae0 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -212,7 +212,8 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " ^ RegionId.Set.to_string None rset2 ^ "\n")); - sanity_check __FILE__ __LINE__ (not (projections_intersect meta ty1 rset1 ty2 rset2))) + sanity_check __FILE__ __LINE__ + (not (projections_intersect meta ty1 rset1 ty2 rset2))) meta; ASymbolic (AProjBorrows (s, ty)) | _ -> @@ -250,7 +251,8 @@ let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) let value = VBorrow (VMutBorrow (bid, bv)) in { value; ty } | SeSharedRef (_, _) -> - craise __FILE__ __LINE__ meta "Unexpected symbolic shared reference expansion" + craise __FILE__ __LINE__ meta + "Unexpected symbolic shared reference expansion" | _ -> symbolic_expansion_non_borrow_to_value meta sv see (** Apply (and reduce) a projector over loans to a value. @@ -262,7 +264,9 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (see : symbolic_expansion) (original_sv_ty : rty) : typed_avalue = (* Sanity check: if we have a proj_loans over a symbolic value, it should * contain regions which we will project *) - sanity_check __FILE__ __LINE__ (ty_has_regions_in_set regions original_sv_ty) meta; + sanity_check __FILE__ __LINE__ + (ty_has_regions_in_set regions original_sv_ty) + meta; (* Match *) let (value, ty) : avalue * ty = match (see, original_sv_ty) with diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index ccf8a5ac..7e6236b1 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -243,7 +243,9 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) a variant with all its fields set to {!Bottom} *) match av.variant_id with - | None -> craise __FILE__ __LINE__ meta "Found a struct value while expected an enum" + | None -> + craise __FILE__ __LINE__ meta + "Found a struct value while expected an enum" | Some variant_id' -> if variant_id' = variant_id then (* Nothing to do *) cf Unit ctx @@ -276,8 +278,10 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) * setting a discriminant should only be used to initialize a value, * or reset an already initialized value, really. *) craise __FILE__ __LINE__ meta "Unexpected value" - | _, (VAdt _ | VBottom) -> craise __FILE__ __LINE__ meta "Inconsistent state" - | _, (VLiteral _ | VBorrow _ | VLoan _) -> craise __FILE__ __LINE__ meta "Unexpected value" + | _, (VAdt _ | VBottom) -> + craise __FILE__ __LINE__ meta "Inconsistent state" + | _, (VLiteral _ | VBorrow _ | VLoan _) -> + craise __FILE__ __LINE__ meta "Unexpected value" in (* Compose and apply *) comp cc update_value cf ctx @@ -434,7 +438,9 @@ let eval_box_new_concrete (config : config) (meta : Meta.meta) :: EBinding (_ret_var, _) :: EFrame :: _ ) -> (* Required type checking *) - cassert __FILE__ __LINE__ (input_value.ty = boxed_ty) meta "TODO: Error message"; + cassert __FILE__ __LINE__ + (input_value.ty = boxed_ty) + meta "TODO: Error message"; (* Move the input value *) let cf_move = @@ -1294,7 +1300,9 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - sanity_check __FILE__ __LINE__ (List.length args = body.arg_count) body.meta; + sanity_check __FILE__ __LINE__ + (List.length args = body.arg_count) + body.meta; let cc = eval_operands config body.meta args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 4fd7722e..4ee11cbd 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -508,8 +508,12 @@ let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (* Generate the type substitution Note that for now we don't support instantiating the type parameters with types containing regions. *) - sanity_check __FILE__ __LINE__ (List.for_all TypesUtils.ty_no_regions generics.types) meta; - sanity_check __FILE__ __LINE__ (TypesUtils.trait_instance_id_no_regions tr_self) meta; + sanity_check __FILE__ __LINE__ + (List.for_all TypesUtils.ty_no_regions generics.types) + meta; + sanity_check __FILE__ __LINE__ + (TypesUtils.trait_instance_id_no_regions tr_self) + meta; let tsubst = Substitute.make_type_subst_from_vars sg.generics.types generics.types in diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 830661d2..642d7a37 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -196,7 +196,9 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let infos = BorrowId.Map.update repr_bid (fun x -> - match x with Some _ -> Some info | None -> craise __FILE__ __LINE__ meta "Unreachable") + match x with + | Some _ -> Some info + | None -> craise __FILE__ __LINE__ meta "Unreachable") !borrows_infos in borrows_infos := infos @@ -212,7 +214,9 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : | RShared, (BShared | BReserved) | RMut, BMut -> () | _ -> craise __FILE__ __LINE__ meta "Invariant not satisfied"); (* A reserved borrow can't point to a value inside an abstraction *) - sanity_check __FILE__ __LINE__ (kind <> BReserved || not info.loan_in_abs) meta; + sanity_check __FILE__ __LINE__ + (kind <> BReserved || not info.loan_in_abs) + meta; (* Insert the borrow id *) let borrow_ids = info.borrow_ids in sanity_check __FILE__ __LINE__ (not (BorrowId.Set.mem bid borrow_ids)) meta; @@ -283,7 +287,10 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : = BorrowId.Set.elements info.borrow_ids) meta; match info.loan_kind with - | RMut -> sanity_check __FILE__ __LINE__ (BorrowId.Set.cardinal info.loan_ids = 1) meta + | RMut -> + sanity_check __FILE__ __LINE__ + (BorrowId.Set.cardinal info.loan_ids = 1) + meta | RShared -> ()) !borrows_infos @@ -373,7 +380,8 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : unit = match (cv, ty) with - | VScalar sv, TInteger int_ty -> sanity_check __FILE__ __LINE__ (sv.int_ty = int_ty) meta + | VScalar sv, TInteger int_ty -> + sanity_check __FILE__ __LINE__ (sv.int_ty = int_ty) meta | VBool _, TBool | VChar _, TChar -> () | _ -> craise __FILE__ __LINE__ meta "Erroneous typing" @@ -481,8 +489,11 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (TypesUtils.const_generic_as_literal cg)) .value in - sanity_check __FILE__ __LINE__ (Z.of_int (List.length inner_values) = len) meta - | (TSlice | TStr), _, _, _, _ -> craise __FILE__ __LINE__ meta "Unexpected" + sanity_check __FILE__ __LINE__ + (Z.of_int (List.length inner_values) = len) + meta + | (TSlice | TStr), _, _, _, _ -> + craise __FILE__ __LINE__ meta "Unexpected" | _ -> craise __FILE__ __LINE__ meta "Erroneous type") | VBottom, _ -> (* Nothing to check *) () | VBorrow bc, TRef (_, ref_ty, rkind) -> ( @@ -503,7 +514,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | _ -> craise __FILE__ __LINE__ meta "Erroneous typing") | VLoan lc, ty -> ( match lc with - | VSharedLoan (_, sv) -> sanity_check __FILE__ __LINE__ (sv.ty = ty) meta + | VSharedLoan (_, sv) -> + sanity_check __FILE__ __LINE__ (sv.ty = ty) meta | VMutLoan bid -> ( (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in @@ -511,7 +523,9 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | Concrete (VMutBorrow (_, bv)) -> sanity_check __FILE__ __LINE__ (bv.ty = ty) meta | Abstract (AMutBorrow (_, sv)) -> - sanity_check __FILE__ __LINE__ (Substitute.erase_regions sv.ty = ty) meta + sanity_check __FILE__ __LINE__ + (Substitute.erase_regions sv.ty = ty) + meta | _ -> craise __FILE__ __LINE__ meta "Inconsistent context")) | VSymbolic sv, ty -> let ty' = Substitute.erase_regions sv.sv_ty in @@ -607,7 +621,9 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - sanity_check __FILE__ __LINE__ (sv.ty = Substitute.erase_regions ref_ty) meta + sanity_check __FILE__ __LINE__ + (sv.ty = Substitute.erase_regions ref_ty) + meta | _ -> craise __FILE__ __LINE__ meta "Inconsistent context") | AIgnoredMutBorrow (_opt_bid, av), RMut -> sanity_check __FILE__ __LINE__ (av.ty = ref_ty) meta @@ -649,7 +665,9 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | AEndedMutLoan { given_back; child; given_back_meta = _ } | AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } -> let borrowed_aty = aloan_get_expected_child_type aty in - sanity_check __FILE__ __LINE__ (given_back.ty = borrowed_aty) meta; + sanity_check __FILE__ __LINE__ + (given_back.ty = borrowed_aty) + meta; sanity_check __FILE__ __LINE__ (child.ty = borrowed_aty) meta | AIgnoredSharedLoan child_av -> sanity_check __FILE__ __LINE__ @@ -664,19 +682,24 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - sanity_check __FILE__ __LINE__ (ty_has_regions_in_set abs.regions sv.sv_ty) meta + sanity_check __FILE__ __LINE__ + (ty_has_regions_in_set abs.regions sv.sv_ty) + meta | AProjBorrows (sv, proj_ty) -> let ty2 = Substitute.erase_regions sv.sv_ty in sanity_check __FILE__ __LINE__ (ty1 = ty2) meta; (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - sanity_check __FILE__ __LINE__ (ty_has_regions_in_set abs.regions proj_ty) meta + sanity_check __FILE__ __LINE__ + (ty_has_regions_in_set abs.regions proj_ty) + meta | AEndedProjLoans (_msv, given_back_ls) -> List.iter (fun (_, proj) -> match proj with - | AProjBorrows (_sv, ty') -> sanity_check __FILE__ __LINE__ (ty' = ty) meta + | AProjBorrows (_sv, ty') -> + sanity_check __FILE__ __LINE__ (ty' = ty) meta | AEndedProjBorrows _ | AIgnoredProjBorrows -> () | _ -> craise __FILE__ __LINE__ meta "Unexpected") given_back_ls @@ -796,7 +819,9 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = *) (* A symbolic value can't be both in the regular environment and inside * projectors of borrows in abstractions *) - sanity_check __FILE__ __LINE__ (info.env_count = 0 || info.aproj_borrows = []) meta; + sanity_check __FILE__ __LINE__ + (info.env_count = 0 || info.aproj_borrows = []) + meta; (* A symbolic value containing borrows can't be duplicated (i.e., copied): * it must be expanded first *) if ty_has_borrows ctx.type_ctx.type_infos info.ty then @@ -806,7 +831,9 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = (info.env_count <= 1 || ty_is_primitively_copyable info.ty) meta; - sanity_check __FILE__ __LINE__ (info.aproj_borrows = [] || info.aproj_loans <> []) meta; + sanity_check __FILE__ __LINE__ + (info.aproj_borrows = [] || info.aproj_loans <> []) + meta; (* At the same time: * - check that the loans don't intersect * - compute the set of regions for which we project loans @@ -818,7 +845,9 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = let regions = RegionId.Set.fold (fun rid regions -> - sanity_check __FILE__ __LINE__ (not (RegionId.Set.mem rid regions)) meta; + sanity_check __FILE__ __LINE__ + (not (RegionId.Set.mem rid regions)) + meta; RegionId.Set.add rid regions) regions linfo.regions in diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index 5e0aa289..11cd89fc 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -238,7 +238,9 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = method! visit_Sequence env st1 st2 = match st1.content with | Loop _ -> - sanity_check __FILE__ __LINE__ (statement_has_no_loop_break_continue st2) st2.meta; + sanity_check __FILE__ __LINE__ + (statement_has_no_loop_break_continue st2) + st2.meta; (replace_breaks_with st1 st2).content | _ -> super#visit_Sequence env st1 st2 end diff --git a/compiler/Print.ml b/compiler/Print.ml index a136f87e..dad1aea3 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -87,7 +87,8 @@ module Values = struct | _ -> craise_opt_meta __FILE__ __LINE__ meta ("Inconsistent value: " ^ show_typed_value v)) - | _ -> craise_opt_meta __FILE__ __LINE__ meta "Inconsistent typed value") + | _ -> craise_opt_meta __FILE__ __LINE__ meta "Inconsistent typed value" + ) | VBottom -> "⊥ : " ^ ty_to_string env v.ty | VBorrow bc -> borrow_content_to_string ~meta env bc | VLoan lc -> loan_content_to_string ~meta env lc @@ -184,7 +185,8 @@ module Values = struct match (aty, field_values) with | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" | _ -> craise_opt_meta __FILE__ __LINE__ meta "Inconsistent value") - | _ -> craise_opt_meta __FILE__ __LINE__ meta "Inconsistent typed value") + | _ -> craise_opt_meta __FILE__ __LINE__ meta "Inconsistent typed value" + ) | ABottom -> "⊥ : " ^ ty_to_string env v.ty | ABorrow bc -> aborrow_content_to_string ~meta env bc | ALoan lc -> aloan_content_to_string ~meta env lc @@ -343,7 +345,8 @@ module Contexts = struct in indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string ~meta env tv ^ " ;" | EAbs abs -> abs_to_string ~meta env verbose indent indent_incr abs - | EFrame -> craise_opt_meta __FILE__ __LINE__ meta "Can't print a Frame element" + | EFrame -> + craise_opt_meta __FILE__ __LINE__ meta "Can't print a Frame element" let opt_env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index a1b19ea3..518d8bdd 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -397,16 +397,21 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) if variant_id = result_return_id then match field_values with | [ v ] -> "@Result::Return " ^ v - | _ -> craise_opt_meta __FILE__ __LINE__ meta "Result::Return takes exactly one value" + | _ -> + craise_opt_meta __FILE__ __LINE__ meta + "Result::Return takes exactly one value" else if variant_id = result_fail_id then match field_values with | [ v ] -> "@Result::Fail " ^ v - | _ -> craise_opt_meta __FILE__ __LINE__ meta "Result::Fail takes exactly one value" + | _ -> + craise_opt_meta __FILE__ __LINE__ meta + "Result::Fail takes exactly one value" else craise_opt_meta __FILE__ __LINE__ meta "Unreachable: improper variant id for result type" | TError -> - cassert_opt_meta __FILE__ __LINE__ (field_values = []) meta "TODO: error message"; + cassert_opt_meta __FILE__ __LINE__ (field_values = []) meta + "TODO: error message"; let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" @@ -416,17 +421,21 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then ( - cassert_opt_meta __FILE__ __LINE__ (field_values = []) meta "TODO: error message"; + cassert_opt_meta __FILE__ __LINE__ (field_values = []) meta + "TODO: error message"; "@Fuel::Zero") else if variant_id = fuel_succ_id then match field_values with | [ v ] -> "@Fuel::Succ " ^ v - | _ -> craise_opt_meta __FILE__ __LINE__ meta "@Fuel::Succ takes exactly one value" + | _ -> + craise_opt_meta __FILE__ __LINE__ meta + "@Fuel::Succ takes exactly one value" else craise_opt_meta __FILE__ __LINE__ meta "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr -> - cassert_opt_meta __FILE__ __LINE__ (variant_id = None) meta "TODO: error message"; + cassert_opt_meta __FILE__ __LINE__ (variant_id = None) meta + "TODO: error message"; let field_values = List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values in diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 95c74a7b..91ee16dc 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -222,7 +222,9 @@ let compute_pretty_names (def : fun_decl) : fun_decl = (* Register a variable for constraints propagation - used when an variable is * introduced (left-hand side of a left binding) *) let register_var (ctx : pn_ctx) (v : var) : pn_ctx = - sanity_check __FILE__ __LINE__ (not (VarId.Map.mem v.id ctx.pure_vars)) def.meta; + sanity_check __FILE__ __LINE__ + (not (VarId.Map.mem v.id ctx.pure_vars)) + def.meta; match v.basename with | None -> ctx | Some name -> @@ -1198,7 +1200,8 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = in let fields = match adt_decl.kind with - | Enum _ | Opaque -> craise __FILE__ __LINE__ def.meta "Unreachable" + | Enum _ | Opaque -> + craise __FILE__ __LINE__ def.meta "Unreachable" | Struct fields -> fields in let num_fields = List.length fields in diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 9e144c50..53ff8983 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -34,7 +34,9 @@ let get_adt_field_types (meta : Meta.meta) let variant_id = Option.get variant_id in if variant_id = result_return_id then [ ty ] else if variant_id = result_fail_id then [ mk_error_ty ] - else craise __FILE__ __LINE__ meta "Unreachable: improper variant id for result type" + else + craise __FILE__ __LINE__ meta + "Unreachable: improper variant id for result type" | TError -> sanity_check __FILE__ __LINE__ (generics = empty_generic_args) meta; let variant_id = Option.get variant_id in @@ -46,11 +48,14 @@ let get_adt_field_types (meta : Meta.meta) let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then [] else if variant_id = fuel_succ_id then [ mk_fuel_ty ] - else craise __FILE__ __LINE__ meta "Unreachable: improper variant id for fuel type" + else + craise __FILE__ __LINE__ meta + "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr | TRawPtr _ -> (* Array: when not symbolic values (for instance, because of aggregates), the array expressions are introduced as struct updates *) - craise __FILE__ __LINE__ meta "Attempting to access the fields of an opaque type") + craise __FILE__ __LINE__ meta + "Attempting to access the fields of an opaque type") type tc_ctx = { type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) @@ -64,7 +69,8 @@ type tc_ctx = { let check_literal (meta : Meta.meta) (v : literal) (ty : literal_type) : unit = match (ty, v) with - | TInteger int_ty, VScalar sv -> sanity_check __FILE__ __LINE__ (int_ty = sv.int_ty) meta + | TInteger int_ty, VScalar sv -> + sanity_check __FILE__ __LINE__ (int_ty = sv.int_ty) meta | TBool, VBool _ | TChar, VChar _ -> () | _ -> craise __FILE__ __LINE__ meta "Inconsistent type" diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 215bebe3..c3afe1c4 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -433,11 +433,14 @@ let mk_switch (meta : Meta.meta) (scrut : texpression) (sb : switch_body) : | If (_, _) -> sanity_check __FILE__ __LINE__ (scrut.ty = TLiteral TBool) meta | Match branches -> List.iter - (fun (b : match_branch) -> sanity_check __FILE__ __LINE__ (b.pat.ty = scrut.ty) meta) + (fun (b : match_branch) -> + sanity_check __FILE__ __LINE__ (b.pat.ty = scrut.ty) meta) branches); (* Sanity check: all the branches have the same type *) let ty = get_switch_body_ty sb in - iter_switch_body_branches (fun e -> sanity_check __FILE__ __LINE__ (e.ty = ty) meta) sb; + iter_switch_body_branches + (fun e -> sanity_check __FILE__ __LINE__ (e.ty = ty) meta) + sb; (* Put together *) let e = Switch (scrut, sb) in { e; ty } @@ -529,7 +532,9 @@ let ty_as_integer (meta : Meta.meta) (t : ty) : T.integer_type = | _ -> craise __FILE__ __LINE__ meta "Unreachable" let ty_as_literal (meta : Meta.meta) (t : ty) : T.literal_type = - match t with TLiteral ty -> ty | _ -> craise __FILE__ __LINE__ meta "Unreachable" + match t with + | TLiteral ty -> ty + | _ -> craise __FILE__ __LINE__ meta "Unreachable" let mk_state_ty : ty = TAdt (TAssumed TState, empty_generic_args) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 031c29f7..aeb03c34 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -445,7 +445,8 @@ and translate_trait_instance_id (meta : Meta.meta) (translate_ty : T.ty -> ty) let inst_id = translate_trait_instance_id inst_id in ItemClause (inst_id, decl_id, item_name, clause_id) | TraitRef tr -> TraitRef (translate_trait_ref meta translate_ty tr) - | FnPointer _ | Closure _ -> craise __FILE__ __LINE__ meta "Closures are not supported yet" + | FnPointer _ | Closure _ -> + craise __FILE__ __LINE__ meta "Closures are not supported yet" | UnknownTrait s -> craise __FILE__ __LINE__ meta ("Unknown trait found: " ^ s) (** Translate a signature type - TODO: factor out the different translation functions *) @@ -457,7 +458,9 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = match type_id with | T.TAdtId adt_id -> TAdt (TAdtId adt_id, generics) | T.TTuple -> - cassert __FILE__ __LINE__ (generics.const_generics = []) meta "TODO: error message"; + cassert __FILE__ __LINE__ + (generics.const_generics = []) + meta "TODO: error message"; mk_simpl_tuple_ty generics.types | T.TAssumed aty -> ( match aty with @@ -817,7 +820,9 @@ let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) (back_funs : texpression option RegionGroupId.Map.t option) (ctx : bs_ctx) : bs_ctx = let calls = ctx.calls in - sanity_check __FILE__ __LINE__ (not (V.FunCallId.Map.mem call_id calls)) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ + (not (V.FunCallId.Map.mem call_id calls)) + ctx.fun_decl.meta; let info = { forward; forward_inputs = args; back_funs } in let calls = V.FunCallId.Map.add call_id info calls in { ctx with calls } @@ -953,7 +958,9 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) (* This is necessarily for the current function *) match fun_id with | FunId (FRegular fid) -> ( - sanity_check __FILE__ __LINE__ (fid = ctx.fun_decl.def_id) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ + (fid = ctx.fun_decl.def_id) + ctx.fun_decl.meta; (* Lookup the loop *) let lid = V.LoopId.Map.find lid ctx.loop_ids_map in let loop_info = LoopId.Map.find lid ctx.loops in @@ -1591,7 +1598,8 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) | VLoan lc -> ( match lc with | VSharedLoan (_, v) -> translate v - | VMutLoan _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") + | VMutLoan _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + ) | VBorrow bc -> ( match bc with | VSharedBorrow bid -> @@ -1726,7 +1734,9 @@ and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = (* The symbolic value was left unchanged *) Some (symbolic_value_to_texpression ctx msv) | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> - sanity_check __FILE__ __LINE__ (child_aproj = AIgnoredProjBorrows) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ + (child_aproj = AIgnoredProjBorrows) + ctx.fun_decl.meta; (* The symbolic value was updated *) Some (symbolic_value_to_texpression ctx mnv) | V.AEndedProjLoans (_, _) -> @@ -2087,9 +2097,13 @@ and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) (ctx : bs_ctx) : texpression = - sanity_check __FILE__ __LINE__ (is_continue = ctx.inside_loop) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ + (is_continue = ctx.inside_loop) + ctx.fun_decl.meta; let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - sanity_check __FILE__ __LINE__ (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ + (loop_id = Option.get ctx.loop_id) + ctx.fun_decl.meta; (* Lookup the loop information *) let loop_id = Option.get ctx.loop_id in @@ -2350,7 +2364,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, dest) - | CastFnPtr _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "TODO: function casts") + | CastFnPtr _ -> + craise __FILE__ __LINE__ ctx.fun_decl.meta "TODO: function casts") | S.Binop binop -> ( match args with | [ arg0; arg1 ] -> @@ -2359,7 +2374,9 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : (match binop with (* The Rust compiler accepts bitshifts for any integer type combination for ty0, ty1 *) | E.Shl | E.Shr -> () - | _ -> sanity_check __FILE__ __LINE__ (int_ty0 = int_ty1) ctx.fun_decl.meta); + | _ -> + sanity_check __FILE__ __LINE__ (int_ty0 = int_ty1) + ctx.fun_decl.meta); let effect_info = { can_fail = ExpressionsUtils.binop_can_fail binop; @@ -2477,7 +2494,9 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) if !Config.type_check_pure_code then List.iter (fun (var, v) -> - sanity_check __FILE__ __LINE__ ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta) + sanity_check __FILE__ __LINE__ + ((var : var).ty = (v : texpression).ty) + ctx.fun_decl.meta) variables_values; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2633,7 +2652,8 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) ^ pure_ty_to_string ctx given_back.ty ^ "\n- sig input ty: " ^ pure_ty_to_string ctx input.ty)); - sanity_check __FILE__ __LINE__ (given_back.ty = input.ty) ctx.fun_decl.meta) + sanity_check __FILE__ __LINE__ (given_back.ty = input.ty) + ctx.fun_decl.meta) given_back_inputs; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2650,7 +2670,9 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) texpression = let vloop_id = loop_id in let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - sanity_check __FILE__ __LINE__ (loop_id = Option.get ctx.loop_id) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ + (loop_id = Option.get ctx.loop_id) + ctx.fun_decl.meta; let rg_id = Option.get rg_id in (* There are two cases depending on the [abs_kind] (whether this is a synth input or a regular loop call) *) @@ -3015,7 +3037,8 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number * of fields!) *) - craise __FILE__ __LINE__ ctx.fun_decl.meta "Attempt to expand a non-expandable value" + craise __FILE__ __LINE__ ctx.fun_decl.meta + "Attempt to expand a non-expandable value" and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) (sv : V.symbolic_value) (v : S.value_aggregate) (e : S.expression) @@ -3542,7 +3565,9 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* Add the loop information in the context *) let ctx = - sanity_check __FILE__ __LINE__ (not (LoopId.Map.mem loop_id ctx.loops)) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ + (not (LoopId.Map.mem loop_id ctx.loops)) + ctx.fun_decl.meta; (* Note that we will retrieve the input values later in the [ForwardEnd] (and will introduce the outputs at that moment, together with the actual diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 74b333f3..576b2809 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -70,7 +70,9 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) VariantId.id option * symbolic_value list = match see with | Some (SeAdt (vid, fields)) -> (vid, fields) - | _ -> craise __FILE__ __LINE__ meta "Ill-formed branching ADT expansion" + | _ -> + craise __FILE__ __LINE__ meta + "Ill-formed branching ADT expansion" in let exp = List.map diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 980ebef7..91010e07 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -33,7 +33,9 @@ let mk_aignored (meta : Meta.meta) (ty : ty) : typed_avalue = { value = AIgnored; ty } let value_as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = - match v with VSymbolic v -> v | _ -> craise __FILE__ __LINE__ meta "Unexpected" + match v with + | VSymbolic v -> v + | _ -> craise __FILE__ __LINE__ meta "Unexpected" (** Box a value *) let mk_box_value (meta : Meta.meta) (v : typed_value) : typed_value = @@ -50,7 +52,9 @@ let is_symbolic (v : value) : bool = match v with VSymbolic _ -> true | _ -> false let as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = - match v with VSymbolic s -> s | _ -> craise __FILE__ __LINE__ meta "Unexpected" + match v with + | VSymbolic s -> s + | _ -> craise __FILE__ __LINE__ meta "Unexpected" let as_mut_borrow (meta : Meta.meta) (v : typed_value) : BorrowId.id * typed_value = -- cgit v1.2.3 From ea086d3391f6086573750f989256119e5d2e7d5c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 29 Mar 2024 15:36:18 +0100 Subject: Cleanup a bit --- compiler/Errors.ml | 60 +++++++++++++++++++--------------------------- compiler/Main.ml | 22 ++++------------- compiler/PureUtils.ml | 1 + compiler/SymbolicToPure.ml | 3 +-- 4 files changed, 31 insertions(+), 55 deletions(-) (limited to 'compiler') diff --git a/compiler/Errors.ml b/compiler/Errors.ml index 41e841f0..04fd708b 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -6,50 +6,38 @@ let meta_to_string (span : Meta.span) = "Source: '" ^ file ^ "', lines " ^ loc_to_string span.beg_loc ^ "-" ^ loc_to_string span.end_loc -let format_error_message (meta : Meta.meta) msg = - msg ^ "\n" ^ meta_to_string meta.span +let format_error_message (meta : Meta.meta option) (msg : string) = + let meta = + match meta with None -> "" | Some meta -> "\n" ^ meta_to_string meta.span + in + msg ^ meta + +let format_error_message_with_file_line (file : string) (line : int) + (meta : Meta.meta option) (msg : string) = + "In file:" ^ file ^ ", line:" ^ string_of_int line ^ "\n" + ^ format_error_message meta msg -exception CFailure of string +exception CFailure of (Meta.meta option * string) let error_list : (Meta.meta option * string) list ref = ref [] -let push_error (file : string) (line : int) (meta : Meta.meta option) - (msg : string) = - error_list := - (meta, msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line) - :: !error_list +let push_error (meta : Meta.meta option) (msg : string) = + error_list := (meta, msg) :: !error_list -let save_error (file : string) (line : int) ?(b : bool = true) +(** Register an error, and throw an exception if [throw] is true *) +let save_error (file : string) (line : int) ?(throw : bool = false) (meta : Meta.meta option) (msg : string) = - push_error file line meta msg; - match meta with - | Some m -> - if !Config.fail_hard && not b then - raise - (Failure - (format_error_message m - (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line))) - | None -> if !Config.fail_hard && not b then raise (Failure msg) + push_error meta msg; + if !Config.fail_hard && throw then + raise (Failure (format_error_message_with_file_line file line meta msg)) let craise_opt_meta (file : string) (line : int) (meta : Meta.meta option) (msg : string) = - match meta with - | Some m -> - if !Config.fail_hard then - raise - (Failure - (format_error_message m - (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line))) - else - let () = push_error file line (Some m) msg in - raise (CFailure msg) - | None -> - if !Config.fail_hard then - raise - (Failure (msg ^ "\n In file:" ^ file ^ "\n Line:" ^ string_of_int line)) - else - let () = push_error file line None msg in - raise (CFailure msg) + if !Config.fail_hard then + raise (Failure (format_error_message_with_file_line file line meta msg)) + else + let () = push_error meta msg in + raise (CFailure (meta, msg)) let craise (file : string) (line : int) (meta : Meta.meta) (msg : string) = craise_opt_meta file line (Some meta) msg @@ -69,7 +57,7 @@ let sanity_check_opt_meta (file : string) (line : int) b meta = cassert_opt_meta file line b meta "Internal error, please file an issue" let internal_error (file : string) (line : int) meta = - craise file line meta "Internal error, please report an issue" + craise file line meta "Internal error, please file an issue" let exec_raise = craise let exec_assert = cassert diff --git a/compiler/Main.ml b/compiler/Main.ml index 798bcec3..64d8ae2b 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -267,6 +267,7 @@ let () = definitions"; fail ()); + (* There may be exceptions to catch *) (try (* Apply the pre-passes *) let m = Aeneas.PrePasses.apply_passes m in @@ -276,24 +277,11 @@ let () = (* Translate the functions *) Aeneas.Translate.translate_crate filename dest_dir m - with Errors.CFailure msg -> + with Errors.CFailure (meta, msg) -> (* In theory it shouldn't happen, but there may be uncaught errors - - note that we let the Failure errors go through *) - (* The error should have been saved *) - let meta = - match !Errors.error_list with - | (m, msg') :: _ -> - (* The last saved message should be the current error - but - good to check *) - if msg = msg' then m else None - | _ -> (* Want to be safe here *) None - in - let msg = - match meta with - | None -> msg - | Some m -> Errors.format_error_message m msg - in - log#serror msg; + note that we let the [Failure] exceptions go through (they are + send if we use the option [-abort-on-error] *) + log#serror (Errors.format_error_message meta msg); exit 1); (* Print total elapsed time *) diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index c3afe1c4..4bc90872 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -325,6 +325,7 @@ let destruct_apps (e : texpression) : texpression * texpression list = let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : texpression = let raise_or_return msg = + (* We shouldn't get there, so we save an error (and eventually raise an exception) *) save_error __FILE__ __LINE__ (Some meta) msg; let e = App (app, arg) in (* Dummy type - TODO: introduce an error type *) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index aeb03c34..ccb4f585 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -2892,8 +2892,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) ^ pure_ty_to_string ctx true_e.ty ^ "\n\nfalse_e.ty: " ^ pure_ty_to_string ctx false_e.ty)); - save_error __FILE__ __LINE__ ~b:(ty = false_e.ty) (Some ctx.fun_decl.meta) - "Internal error, please file an issue"; + sanity_check __FILE__ __LINE__ (ty = false_e.ty) ctx.fun_decl.meta; { e; ty } | ExpandInt (int_ty, branches, otherwise) -> let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : -- cgit v1.2.3 From 9403920e1e46157089f78bc42c553eec38181fa9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 29 Mar 2024 15:42:56 +0100 Subject: Improve the error messages --- compiler/Errors.ml | 16 +++++++++++----- compiler/Extract.ml | 5 ++++- compiler/Logging.ml | 3 +++ 3 files changed, 18 insertions(+), 6 deletions(-) (limited to 'compiler') diff --git a/compiler/Errors.ml b/compiler/Errors.ml index 04fd708b..53e56c44 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -1,3 +1,5 @@ +let log = Logging.errors_log + let meta_to_string (span : Meta.span) = let file = match span.file with Virtual s | Local s -> s in let loc_to_string (l : Meta.loc) : string = @@ -14,7 +16,7 @@ let format_error_message (meta : Meta.meta option) (msg : string) = let format_error_message_with_file_line (file : string) (line : int) (meta : Meta.meta option) (msg : string) = - "In file:" ^ file ^ ", line:" ^ string_of_int line ^ "\n" + "In file " ^ file ^ ", line " ^ string_of_int line ^ ":\n" ^ format_error_message meta msg exception CFailure of (Meta.meta option * string) @@ -28,13 +30,17 @@ let push_error (meta : Meta.meta option) (msg : string) = let save_error (file : string) (line : int) ?(throw : bool = false) (meta : Meta.meta option) (msg : string) = push_error meta msg; - if !Config.fail_hard && throw then - raise (Failure (format_error_message_with_file_line file line meta msg)) + if !Config.fail_hard && throw then ( + let msg = format_error_message_with_file_line file line meta msg in + log#serror (msg ^ "\n"); + raise (Failure msg)) let craise_opt_meta (file : string) (line : int) (meta : Meta.meta option) (msg : string) = - if !Config.fail_hard then - raise (Failure (format_error_message_with_file_line file line meta msg)) + if !Config.fail_hard then ( + let msg = format_error_message_with_file_line file line meta msg in + log#serror (msg ^ "\n"); + raise (Failure (format_error_message_with_file_line file line meta msg))) else let () = push_error meta msg in raise (CFailure (meta, msg)) diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 1a9b3baa..ad204f7a 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2234,7 +2234,10 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) (* For now we do not support overriding provided methods *) cassert __FILE__ __LINE__ (trait_impl.provided_methods = []) - trait_impl.meta "Overriding provided methods is not supported yet"; + trait_impl.meta + ("Overriding provided methods is not supported yet (overriden methods: " + ^ String.concat ", " (List.map fst trait_impl.provided_methods) + ^ ")"); (* Everything is taken care of by {!extract_trait_decl_register_names} *but* the name of the implementation itself *) (* Compute the name *) diff --git a/compiler/Logging.ml b/compiler/Logging.ml index 9c20f32f..9b8019b2 100644 --- a/compiler/Logging.ml +++ b/compiler/Logging.ml @@ -3,6 +3,9 @@ include Charon.Logging (** Below, we create subgloggers for various submodules, so that we can precisely toggle logging on/off, depending on which information we need *) +(** Logger for Errors *) +let errors_log = L.get_logger "MainLogger.Errors" + (** Logger for PrePasses *) let pre_passes_log = L.get_logger "MainLogger.PrePasses" -- cgit v1.2.3 From c26dcd0a0e5dd35d486d3eed374644b115574408 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 29 Mar 2024 16:13:13 +0100 Subject: Add some missing error messages --- compiler/Extract.ml | 7 ++----- compiler/ExtractTypes.ml | 4 ++-- compiler/InterpreterStatements.ml | 4 ++-- 3 files changed, 6 insertions(+), 9 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index ad204f7a..d6a5f0fc 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1876,11 +1876,8 @@ let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : global_decl) (body : fun_decl) (interface : bool) : unit = let meta = body.meta in - cassert __FILE__ __LINE__ body.is_global_decl_body body.meta - "TODO: Error message"; - cassert __FILE__ __LINE__ - (body.signature.inputs = []) - body.meta "TODO: Error message"; + sanity_check __FILE__ __LINE__ body.is_global_decl_body body.meta; + sanity_check __FILE__ __LINE__ (body.signature.inputs = []) body.meta; (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 6dbf528c..1f0abf8a 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -554,9 +554,9 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) *) match trait_ref.trait_id with | Self -> - cassert __FILE__ __LINE__ + sanity_check __FILE__ __LINE__ (trait_ref.generics = empty_generic_args) - meta "TODO: Error message"; + meta; extract_trait_instance_id_with_dot meta ctx fmt no_params_tys false trait_ref.trait_id; F.pp_print_string fmt type_name diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 7e6236b1..1cf1c5ef 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -440,7 +440,7 @@ let eval_box_new_concrete (config : config) (meta : Meta.meta) (* Required type checking *) cassert __FILE__ __LINE__ (input_value.ty = boxed_ty) - meta "TODO: Error message"; + meta "The input given to Box::new doesn't have the proper type"; (* Move the input value *) let cf_move = @@ -1431,7 +1431,7 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (fun ((arg, rty) : typed_value * rty) -> arg.ty = Subst.erase_regions rty) args_with_rtypes) - meta "TODO: Error message"; + meta "The input arguments don't have the proper type"; (* Check that the input arguments don't contain symbolic values that can't * be fed to functions (i.e., symbolic values output from function return * values and which contain borrows of borrows can't be used as function -- cgit v1.2.3 From 5809c45fbbfcbb78b15a97be619dcde4ab4868b8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 29 Mar 2024 16:21:15 +0100 Subject: Add some error messages --- compiler/AssociatedTypes.ml | 12 ++++++------ compiler/InterpreterExpressions.ml | 7 +++++-- compiler/InterpreterLoopsMatchCtxs.ml | 4 ++-- compiler/InterpreterProjectors.ml | 2 +- compiler/PrintPure.ml | 6 +++--- compiler/PureMicroPasses.ml | 8 ++++---- compiler/Substitute.ml | 2 +- compiler/SymbolicToPure.ml | 13 +++++++------ 8 files changed, 29 insertions(+), 25 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 083a38d1..27425a51 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -428,12 +428,12 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) - cassert_opt_meta __FILE__ __LINE__ + sanity_check_opt_meta __FILE__ __LINE__ (trait_instance_id_is_local_clause trait_ref.trait_id) - ctx.meta "Trait instance id is not a local sub-clause"; - cassert_opt_meta __FILE__ __LINE__ + ctx.meta; + sanity_check_opt_meta __FILE__ __LINE__ (trait_ref.generics = empty_generic_args) - ctx.meta "TODO: error message"; + ctx.meta; (trait_ref.trait_id, None) | FnPointer ty -> let ty = norm_ctx_normalize_ty ctx ty in @@ -482,9 +482,9 @@ and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : trait_ref) : (lazy ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); - cassert_opt_meta __FILE__ __LINE__ + sanity_check_opt_meta __FILE__ __LINE__ (generics = empty_generic_args) - ctx.meta "TODO: error message"; + ctx.meta; trait_ref (* Not sure this one is really necessary *) diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index d61ba410..48a1cce6 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -340,7 +340,9 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) value_as_symbolic meta cv.value, SymbolicAst.VaCgValue vid, e ))) - | CFnPtr _ -> craise __FILE__ __LINE__ meta "TODO: error message") + | CFnPtr _ -> + craise __FILE__ __LINE__ meta + "Function pointers are not supported yet") | Copy p -> (* Access the value *) let access = Read in @@ -523,7 +525,8 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) * The remaining binops only operate on scalars. *) if binop = Eq || binop = Ne then ( (* Equality operations *) - exec_assert __FILE__ __LINE__ (v1.ty = v2.ty) meta "TODO: error message"; + exec_assert __FILE__ __LINE__ (v1.ty = v2.ty) meta + "The arguments given to the binop don't have the same type"; (* Equality/inequality check is primitive only for a subset of types *) exec_assert __FILE__ __LINE__ (ty_is_primitively_copyable v1.ty) diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 6d814c5c..bd271ff4 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -243,7 +243,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct (not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) - M.meta "TODO: error message"; + M.meta "The join of nested borrows is not supported yet"; let bid, bv = M.match_mut_borrows ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv in @@ -268,7 +268,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let sv = match_rec sv0 sv1 in cassert __FILE__ __LINE__ (not (value_has_borrows sv.value)) - M.meta "TODO: error message"; + M.meta "The join of nested borrows is not supported yet"; let ids, sv = M.match_shared_loans ctx0 ctx1 ty ids0 ids1 sv in VSharedLoan (ids, sv) | VMutLoan id0, VMutLoan id1 -> diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index d7c20ae0..8b6eeb6c 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -502,7 +502,7 @@ let apply_proj_borrows_on_input_value (config : config) (meta : Meta.meta) (ctx : eval_ctx) (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = - cassert __FILE__ __LINE__ (ty_is_rty ty) meta "TODO: error message"; + sanity_check __FILE__ __LINE__ (ty_is_rty ty) meta; let check_symbolic_no_ended = true in let allow_reborrows = true in (* Prepare the reborrows *) diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 518d8bdd..d0c243bb 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -411,7 +411,7 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) "Unreachable: improper variant id for result type" | TError -> cassert_opt_meta __FILE__ __LINE__ (field_values = []) meta - "TODO: error message"; + "Ill-formed error value"; let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" @@ -422,7 +422,7 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then ( cassert_opt_meta __FILE__ __LINE__ (field_values = []) meta - "TODO: error message"; + "Ill-formed full value"; "@Fuel::Zero") else if variant_id = fuel_succ_id then match field_values with @@ -435,7 +435,7 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr -> cassert_opt_meta __FILE__ __LINE__ (variant_id = None) meta - "TODO: error message"; + "Ill-formed value"; let field_values = List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values in diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 91ee16dc..12b3387a 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1402,9 +1402,9 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : { fwd_info; effect_info = loop_fwd_effect_info; ignore_output } in - cassert __FILE__ __LINE__ + sanity_check __FILE__ __LINE__ (fun_sig_info_is_wf loop_fwd_sig_info) - def.meta "TODO: error message"; + def.meta; let inputs_tys = let fuel = if !Config.use_fuel then [ mk_fuel_ty ] else [] in @@ -1444,10 +1444,10 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : (* Introduce the forward input state *) let fwd_state_var, fwd_state_lvs = - cassert __FILE__ __LINE__ + sanity_check __FILE__ __LINE__ (loop_fwd_effect_info.stateful = Option.is_some loop.input_state) - def.meta "TODO: error message"; + def.meta; match loop.input_state with | None -> ([], []) | Some input_state -> diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index b9eebc25..177d8c24 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -77,7 +77,7 @@ let ctx_adt_value_get_instantiated_field_types (meta : Meta.meta) ctx_adt_get_instantiated_field_types ctx id adt.variant_id generics | TTuple -> cassert __FILE__ __LINE__ (generics.regions = []) meta - "Regions should be empty TODO: error message"; + "Tuples don't have region parameters"; generics.types | TAssumed aty -> ( match aty with diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index ccb4f585..4830f65a 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -458,9 +458,7 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = match type_id with | T.TAdtId adt_id -> TAdt (TAdtId adt_id, generics) | T.TTuple -> - cassert __FILE__ __LINE__ - (generics.const_generics = []) - meta "TODO: error message"; + sanity_check __FILE__ __LINE__ (generics.const_generics = []) meta; mk_simpl_tuple_ty generics.types | T.TAssumed aty -> ( match aty with @@ -486,7 +484,8 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = | TTraitType (trait_ref, type_name) -> let trait_ref = translate_strait_ref meta trait_ref in TTraitType (trait_ref, type_name) - | TArrow _ -> craise __FILE__ __LINE__ meta "TODO: error message" + | TArrow _ -> + craise __FILE__ __LINE__ meta "Arrow types are not supported yet" and translate_sgeneric_args (meta : Meta.meta) (generics : T.generic_args) : generic_args = @@ -659,7 +658,8 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) | TTraitType (trait_ref, type_name) -> let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in TTraitType (trait_ref, type_name) - | TArrow _ -> craise __FILE__ __LINE__ meta "TODO: error message" + | TArrow _ -> + craise __FILE__ __LINE__ meta "Arrow types are not supported yet" and translate_fwd_generic_args (meta : Meta.meta) (type_infos : type_infos) (generics : T.generic_args) : generic_args = @@ -768,7 +768,8 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) let trait_ref = translate_fwd_trait_ref meta type_infos trait_ref in Some (TTraitType (trait_ref, type_name)) else None - | TArrow _ -> craise __FILE__ __LINE__ meta "TODO: error message" + | TArrow _ -> + craise __FILE__ __LINE__ meta "Arrow types are not supported yet" (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) -- cgit v1.2.3 From 16bebef339ee390b77e5b5505126aba74019a8f8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 29 Mar 2024 16:23:03 +0100 Subject: Add an error message --- compiler/Contexts.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'compiler') diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index edda4260..0a62f5ef 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -404,9 +404,7 @@ let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) (fun (var, (value : typed_value)) -> TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) vars) - meta - "The pushed variables and their values do not have the same type TODO: \ - Error message"; + meta "The pushed variables and their values do not have the same type"; let vars = List.map (fun (var, value) -> EBinding (BVar (var_to_binder var), value)) -- cgit v1.2.3 From 1a86cac476c1f5c0d64d5a12db267d3ac651561b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 29 Mar 2024 17:49:46 +0100 Subject: Cleanup and fix a mistake --- compiler/Extract.ml | 12 +- compiler/FunsAnalysis.ml | 6 +- compiler/InterpreterBorrows.ml | 29 ++--- compiler/InterpreterBorrowsCore.ml | 2 +- compiler/InterpreterLoopsCore.ml | 7 +- compiler/InterpreterLoopsJoinCtxs.ml | 10 +- compiler/InterpreterLoopsMatchCtxs.ml | 41 ++++--- compiler/InterpreterPaths.ml | 2 +- compiler/InterpreterProjectors.ml | 32 ++--- compiler/PrePasses.ml | 2 +- compiler/PureMicroPasses.ml | 1 + compiler/SymbolicToPure.ml | 221 +++++++++++++++------------------- compiler/Translate.ml | 1 + 13 files changed, 172 insertions(+), 194 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index d6a5f0fc..1f9c9117 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -509,8 +509,6 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) | Error (types, err) -> extract_generic_args meta ctx fmt TypeDeclId.Set.empty { generics with types }; - (* if !Config.fail_hard then craise __FILE__ __LINE__ meta err - else *) save_error __FILE__ __LINE__ (Some meta) err; F.pp_print_string fmt "(\"ERROR: ill-formed builtin: invalid number of filtering \ @@ -1876,8 +1874,8 @@ let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : global_decl) (body : fun_decl) (interface : bool) : unit = let meta = body.meta in - sanity_check __FILE__ __LINE__ body.is_global_decl_body body.meta; - sanity_check __FILE__ __LINE__ (body.signature.inputs = []) body.meta; + sanity_check __FILE__ __LINE__ body.is_global_decl_body meta; + sanity_check __FILE__ __LINE__ (body.signature.inputs = []) meta; (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; @@ -2232,7 +2230,8 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) cassert __FILE__ __LINE__ (trait_impl.provided_methods = []) trait_impl.meta - ("Overriding provided methods is not supported yet (overriden methods: " + ("Overriding trait provided methods in trait implementations is not \ + supported yet (overriden methods: " ^ String.concat ", " (List.map fst trait_impl.provided_methods) ^ ")"); (* Everything is taken care of by {!extract_trait_decl_register_names} *but* @@ -2622,8 +2621,7 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) in extract_trait_impl_item ctx fmt fun_name ty -(** Extract a trait implementation -*) +(** Extract a trait implementation *) let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (impl : trait_impl) : unit = log#ldebug (lazy ("extract_trait_impl: " ^ name_to_string ctx impl.llbc_name)); diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index cad469f9..f194d4e5 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -119,7 +119,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) method! visit_Call env call = (match call.func with | FnOpMove _ -> - (* Ignoring this: we lookup t he called function upon creating + (* Ignoring this: we lookup the called function upon creating the closure *) () | FnOpRegular func -> ( @@ -145,9 +145,9 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) end in (* Sanity check: global bodies don't contain stateful calls *) - sanity_check __FILE__ __LINE__ + cassert __FILE__ __LINE__ ((not f.is_global_decl_body) || not !stateful) - f.meta; + f.meta "Global definition containing a stateful call in its body"; let builtin_info = get_builtin_info f in let has_builtin_info = builtin_info <> None in group_has_builtin_info := !group_has_builtin_info || has_builtin_info; diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index b32261e6..e593ae75 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -443,8 +443,7 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - cassert __FILE__ __LINE__ !replaced meta - "Only one loan should have been given back"; + cassert __FILE__ __LINE__ !replaced meta "No loan updated"; (* Apply the reborrows *) apply_registered_reborrows ctx @@ -503,7 +502,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) let replaced : bool ref = ref false in let set_replaced () = cassert __FILE__ __LINE__ (not !replaced) meta - "Only one loan should have been updated"; + "Exacly one loan should be updated"; replaced := true in let obj = @@ -589,7 +588,7 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - cassert __FILE__ __LINE__ !replaced meta "Only one loan should be given back"; + cassert __FILE__ __LINE__ !replaced meta "No loan updated"; (* Return *) ctx @@ -608,7 +607,7 @@ let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) let replaced : bool ref = ref false in let set_replaced () = cassert __FILE__ __LINE__ (not !replaced) meta - "Only one loan should be updated"; + "Exactly one loan should be updated"; replaced := true in let obj = @@ -673,8 +672,7 @@ let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (* Explore the environment *) let ctx = obj#visit_eval_ctx None ctx in (* Check we gave back to exactly one loan *) - cassert __FILE__ __LINE__ !replaced meta - "Exactly one loan should be given back"; + cassert __FILE__ __LINE__ !replaced meta "No loan updated"; (* Return *) ctx @@ -1553,8 +1551,8 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) craise __FILE__ __LINE__ meta - "Can't promote a shared loan to a mutable loan if the loan is inside \ - an abstraction" + "Can't promote a shared loan to a mutable loan if the loan is inside a \ + region abstraction" (** Helper function: see {!activate_reserved_mut_borrow}. @@ -1581,7 +1579,7 @@ let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) (* This can't happen for sure *) craise __FILE__ __LINE__ meta "Can't promote a shared borrow to a mutable borrow if the borrow is \ - inside an abstraction" + inside a region abstraction" in (* Continue *) cf ctx @@ -1647,7 +1645,7 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) * returned by abstractions. I'm not sure how we could handle that anyway. *) craise __FILE__ __LINE__ meta "Can't activate a reserved mutable borrow referencing a loan inside\n\ - \ an abstraction" + \ a region abstraction" let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (destructure_shared_values : bool) (ctx : eval_ctx) (abs0 : abs) : abs = @@ -2272,12 +2270,11 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) - if merge_funs = None then - (sanity_check __FILE__ __LINE__ - (BorrowId.Set.disjoint borrows0 borrows1) - meta; - sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint loans0 loans1)) + if merge_funs = None then ( + sanity_check __FILE__ __LINE__ + (BorrowId.Set.disjoint borrows0 borrows1) meta; + sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint loans0 loans1) meta); (* Merge. There are several cases: diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 92d8670a..6e65b11d 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -864,7 +864,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) let ctx = obj#visit_eval_ctx None ctx in (* Check that we updated the context at least once *) cassert __FILE__ __LINE__ (Option.is_some !shared) meta - "Context was not updated at least once"; + "Context was not updated"; (* Return *) ctx diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 2283e842..a5b3a021 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -256,12 +256,12 @@ module type PrimMatcher = sig end module type Matcher = sig + val meta : Meta.meta + (** Match two values. Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) - val meta : Meta.meta - val match_typed_values : eval_ctx -> eval_ctx -> typed_value -> typed_value -> typed_value @@ -279,6 +279,8 @@ end Very annoying: functors only take modules as inputs... *) module type MatchCheckEquivState = sig + val meta : Meta.meta + (** [true] if we check equivalence between contexts, [false] if we match a source context with a target context. *) val check_equiv : bool @@ -299,7 +301,6 @@ module type MatchCheckEquivState = sig val aid_map : AbstractionId.InjSubst.t ref val lookup_shared_value_in_ctx0 : BorrowId.id -> typed_value val lookup_shared_value_in_ctx1 : BorrowId.id -> typed_value - val meta : Meta.meta end module type CheckEquivMatcher = sig diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index d97b05d0..de00cb93 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -491,8 +491,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) are not in the prefix anymore *) if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Still in the prefix: match the values *) - cassert __FILE__ __LINE__ (b0 = b1) meta - "Bindings are not the same. We are not in the prefix anymore"; + sanity_check __FILE__ __LINE__ (b0 = b1) meta; let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in let var = EBinding (BDummy b, v) in @@ -514,9 +513,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (* Variable bindings *must* be in the prefix and consequently their ids must be the same *) - cassert __FILE__ __LINE__ (b0 = b1) meta - "Variable bindings *must* be in the prefix and consequently their\n\ - \ ids must be the same"; + sanity_check __FILE__ __LINE__ (b0 = b1) meta; (* Match the values *) let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in @@ -537,8 +534,7 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (* Same as for the dummy values: there are two cases *) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( (* Still in the prefix: the abstractions must be the same *) - cassert __FILE__ __LINE__ (abs0 = abs1) meta - "The abstractions are not the same"; + sanity_check __FILE__ __LINE__ (abs0 = abs1) meta; (* Continue *) abs :: join_prefixes env0' env1') else (* Not in the prefix anymore *) diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index bd271ff4..e710ed2b 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -827,13 +827,13 @@ end (* Very annoying: functors only take modules as inputs... *) module type MatchMoveState = sig + val meta : Meta.meta + (** The current loop *) val loop_id : LoopId.id (** The moved values *) val nvalues : typed_value list ref - - val meta : Meta.meta end (* We use this matcher to move values in environment. @@ -853,9 +853,9 @@ end indeed matches the resulting target environment: it will be re-checked later. *) module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct - (** Small utility *) let meta = S.meta + (** Small utility *) let push_moved_value (v : typed_value) : unit = S.nvalues := v :: !S.nvalues let match_etys _ _ ty0 ty1 = @@ -959,6 +959,8 @@ end module MakeCheckEquivMatcher (S : MatchCheckEquivState) : CheckEquivMatcher = struct + let meta = S.meta + module MkGetSetM (Id : Identifiers.Id) = struct module Inj = Id.InjSubst @@ -1001,8 +1003,6 @@ struct (match_el msg m (Id.Set.elements ks0) (Id.Set.elements ks1)) end - let meta = S.meta - module GetSetRid = MkGetSetM (RegionId) let match_rid = GetSetRid.match_e "match_rid: " S.rid_map @@ -1383,15 +1383,15 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) | EBinding (BDummy b0, v0) :: env0', EBinding (BDummy b1, v1) :: env1' -> (* Sanity check: if the dummy value is an old value, the bindings must be the same and their values equal (and the borrows/loans/symbolic *) - if DummyVarId.Set.mem b0 fixed_ids.dids then - ((* Fixed values: the values must be equal *) - sanity_check __FILE__ __LINE__ (b0 = b1) meta; - sanity_check __FILE__ __LINE__ (v0 = v1) meta; - (* The ids present in the left value must be fixed *) - let ids, _ = compute_typed_value_ids v0 in - sanity_check __FILE__ __LINE__ - ((not S.check_equiv) || ids_are_fixed ids)) - meta; + if DummyVarId.Set.mem b0 fixed_ids.dids then ( + (* Fixed values: the values must be equal *) + sanity_check __FILE__ __LINE__ (b0 = b1) meta; + sanity_check __FILE__ __LINE__ (v0 = v1) meta; + (* The ids present in the left value must be fixed *) + let ids, _ = compute_typed_value_ids v0 in + sanity_check __FILE__ __LINE__ + ((not S.check_equiv) || ids_are_fixed ids) + meta); (* We still match the values - allows to compute mappings (which are the identity actually) *) let _ = M.match_typed_values ctx0 ctx1 v0 v1 in @@ -1457,9 +1457,16 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) } in Some maps - with Distinct msg -> - log#ldebug (lazy ("match_ctxs: distinct: " ^ msg)); - None + with + | Distinct msg -> + log#ldebug (lazy ("match_ctxs: distinct: " ^ msg ^ "\n")); + None + | ValueMatchFailure k -> + log#ldebug + (lazy + ("match_ctxs: distinct: ValueMatchFailure" ^ show_updt_env_kind k + ^ "\n")); + None let ctxs_are_equivalent (meta : Meta.meta) (fixed_ids : ids_sets) (ctx0 : eval_ctx) (ctx1 : eval_ctx) : bool = diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 93e56106..f2c0bcb1 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -483,7 +483,7 @@ let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (Some (Synth.mk_mplace meta prefix ctx)) | FailBottom (_, _, _) -> (* We can't expand {!Bottom} values while reading them *) - craise __FILE__ __LINE__ meta "Found [Bottom] while reading a place" + craise __FILE__ __LINE__ meta "Found bottom while reading a place" | FailBorrow _ -> craise __FILE__ __LINE__ meta "Could not read a borrow" in diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 8b6eeb6c..6e86e6a4 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -199,22 +199,22 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) | VSymbolic s, _ -> (* Check that the projection doesn't contain already ended regions, * if necessary *) - if check_symbolic_no_ended then - (let ty1 = s.sv_ty in - let rset1 = ctx.ended_regions in - let ty2 = ty in - let rset2 = regions in - log#ldebug - (lazy - ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1 - ^ "\n- rset1: " - ^ RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " - ^ RegionId.Set.to_string None rset2 - ^ "\n")); - sanity_check __FILE__ __LINE__ - (not (projections_intersect meta ty1 rset1 ty2 rset2))) - meta; + if check_symbolic_no_ended then ( + let ty1 = s.sv_ty in + let rset1 = ctx.ended_regions in + let ty2 = ty in + let rset2 = regions in + log#ldebug + (lazy + ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1 + ^ "\n- rset1: " + ^ RegionId.Set.to_string None rset1 + ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " + ^ RegionId.Set.to_string None rset2 + ^ "\n")); + sanity_check __FILE__ __LINE__ + (not (projections_intersect meta ty1 rset1 ty2 rset2)) + meta); ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index 11cd89fc..0b39f64a 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -402,8 +402,8 @@ let remove_shallow_borrows (crate : crate) (f : fun_decl) : fun_decl = let check_visitor = object inherit [_] iter_statement as super - (* Remember the span of the statement we enter *) + (* Remember the span of the statement we enter *) method! visit_statement _ st = super#visit_statement st.meta st method! visit_var_id meta id = diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 12b3387a..9fa07029 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1989,6 +1989,7 @@ let filter_loop_inputs (ctx : trans_ctx) (transl : pure_fun_translation list) : (List.concat (List.map (fun { f; loops } -> [ f :: loops ]) transl)) in let subgroups = ReorderDecls.group_reorder_fun_decls all_decls in + log#ldebug (lazy ("filter_loop_inputs: all_decls:\n\n" diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 4830f65a..0c30f44c 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -144,6 +144,7 @@ type loop_info = { (** Body synthesis context *) type bs_ctx = { (* TODO: there are a lot of duplications with the various decls ctx *) + meta : Meta.meta; (** The meta information about the current declaration *) decls_ctx : C.decls_ctx; type_ctx : type_ctx; fun_ctx : fun_ctx; @@ -325,7 +326,7 @@ let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = let typed_value_to_string (ctx : bs_ctx) (v : V.typed_value) : string = let env = bs_ctx_to_fmt_env ctx in - Print.Values.typed_value_to_string ~meta:(Some ctx.fun_decl.meta) env v + Print.Values.typed_value_to_string ~meta:(Some ctx.meta) env v let pure_ty_to_string (ctx : bs_ctx) (ty : ty) : string = let env = bs_ctx_to_pure_fmt_env ctx in @@ -349,8 +350,7 @@ let pure_type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.texpression_to_string ~metadata:(Some ctx.fun_decl.meta) env false - "" " " e + PrintPure.texpression_to_string ~metadata:(Some ctx.meta) env false "" " " e let fun_id_to_string (ctx : bs_ctx) (id : A.fun_id) : string = let env = bs_ctx_to_fmt_env ctx in @@ -364,10 +364,9 @@ let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = let env = bs_ctx_to_pure_fmt_env ctx in PrintPure.fun_decl_to_string env def -let typed_pattern_to_string ?(meta : Meta.meta option = None) (ctx : bs_ctx) - (p : Pure.typed_pattern) : string = +let typed_pattern_to_string (ctx : bs_ctx) (p : Pure.typed_pattern) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.typed_pattern_to_string ~meta env p + PrintPure.typed_pattern_to_string ~meta:(Some ctx.meta) env p let ctx_get_effect_info_for_bid (ctx : bs_ctx) (bid : RegionGroupId.id option) : fun_effect_info = @@ -386,7 +385,7 @@ let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = let verbose = false in let indent = "" in let indent_incr = " " in - Print.Values.abs_to_string ~meta:(Some ctx.fun_decl.meta) env verbose indent + Print.Values.abs_to_string ~meta:(Some ctx.meta) env verbose indent indent_incr abs let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : @@ -676,13 +675,13 @@ and translate_fwd_trait_instance_id (meta : Meta.meta) (type_infos : type_infos) (** Simply calls [translate_fwd_ty] *) let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : T.ty) : ty = let type_infos = ctx.type_ctx.type_infos in - translate_fwd_ty ctx.fun_decl.meta type_infos ty + translate_fwd_ty ctx.meta type_infos ty (** Simply calls [translate_fwd_generic_args] *) let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : T.generic_args) : generic_args = let type_infos = ctx.type_ctx.type_infos in - translate_fwd_generic_args ctx.fun_decl.meta type_infos generics + translate_fwd_generic_args ctx.meta type_infos generics (** Translate a type, when some regions may have ended. @@ -775,7 +774,7 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) (inside_mut : bool) (ty : T.ty) : ty option = let type_infos = ctx.type_ctx.type_infos in - translate_back_ty ctx.fun_decl.meta type_infos keep_region inside_mut ty + translate_back_ty ctx.meta type_infos keep_region inside_mut ty let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = let const_generics = @@ -794,14 +793,14 @@ let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = } let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = - let meta = ctx.fun_decl.meta in + let meta = ctx.meta in let ctx = mk_type_check_ctx ctx in let _ = PureTypeCheck.check_typed_pattern meta ctx v in () let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = if !Config.type_check_pure_code then - let meta = ctx.fun_decl.meta in + let meta = ctx.meta in let ctx = mk_type_check_ctx ctx in PureTypeCheck.check_texpression meta ctx e @@ -811,9 +810,7 @@ let translate_fun_id_or_trait_method_ref (ctx : bs_ctx) | FunId fun_id -> FunId fun_id | TraitMethod (trait_ref, method_name, fun_decl_id) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = - translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref - in + let trait_ref = translate_fwd_trait_ref ctx.meta type_infos trait_ref in TraitMethod (trait_ref, method_name, fun_decl_id) let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) @@ -823,7 +820,7 @@ let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) let calls = ctx.calls in sanity_check __FILE__ __LINE__ (not (V.FunCallId.Map.mem call_id calls)) - ctx.fun_decl.meta; + ctx.meta; let info = { forward; forward_inputs = args; back_funs } in let calls = V.FunCallId.Map.add call_id info calls in { ctx with calls } @@ -847,7 +844,7 @@ let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) let abstractions = ctx.abstractions in sanity_check __FILE__ __LINE__ (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) - ctx.fun_decl.meta; + ctx.meta; let abstractions = V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions in @@ -953,22 +950,20 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) in { info with is_rec = info.is_rec || Option.is_some lid } | FunId (FAssumed _) -> - compute_raw_fun_effect_info ctx.fun_decl.meta ctx.fun_ctx.fun_infos - fun_id lid gid) + compute_raw_fun_effect_info ctx.meta ctx.fun_ctx.fun_infos fun_id lid + gid) | Some lid -> ( (* This is necessarily for the current function *) match fun_id with | FunId (FRegular fid) -> ( - sanity_check __FILE__ __LINE__ - (fid = ctx.fun_decl.def_id) - ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (fid = ctx.fun_decl.def_id) ctx.meta; (* Lookup the loop *) let lid = V.LoopId.Map.find lid ctx.loop_ids_map in let loop_info = LoopId.Map.find lid ctx.loops in match gid with | None -> loop_info.fwd_effect_info | Some gid -> RegionGroupId.Map.find gid loop_info.back_effect_infos) - | _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") + | _ -> craise __FILE__ __LINE__ ctx.meta "Unreachable") (** Translate a function signature to a decomposed function signature. @@ -1514,7 +1509,7 @@ let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = match V.SymbolicValueId.Map.find_opt sv.sv_id ctx.sv_to_var with | Some v -> v | None -> - craise __FILE__ __LINE__ ctx.fun_decl.meta + craise __FILE__ __LINE__ ctx.meta ("Could not find var for symbolic value: " ^ V.SymbolicValueId.to_string sv.sv_id) @@ -1564,7 +1559,7 @@ let symbolic_value_to_texpression (ctx : bs_ctx) (sv : V.symbolic_value) : let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) (v : V.typed_value) : texpression = (* We need to ignore boxes *) - let v = unbox_typed_value ctx.fun_decl.meta v in + let v = unbox_typed_value ctx.meta v in let translate = typed_value_to_texpression ctx ectx in (* Translate the type *) let ty = ctx_translate_fwd_ty ctx v.ty in @@ -1578,12 +1573,12 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) match v.ty with | TAdt (TTuple, _) -> - sanity_check __FILE__ __LINE__ (variant_id = None) ctx.fun_decl.meta; - mk_simpl_tuple_texpression ctx.fun_decl.meta field_values + sanity_check __FILE__ __LINE__ (variant_id = None) ctx.meta; + mk_simpl_tuple_texpression ctx.meta field_values | _ -> (* Retrieve the type and the translated generics from the translated type (simpler this way) *) - let adt_id, generics = ty_as_adt ctx.fun_decl.meta ty in + let adt_id, generics = ty_as_adt ctx.meta ty in (* Create the constructor *) let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in let qualif = { id = qualif_id; generics } in @@ -1594,20 +1589,18 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) let cons_ty = mk_arrows field_tys ty in let cons = { e = cons_e; ty = cons_ty } in (* Apply the constructor *) - mk_apps ctx.fun_decl.meta cons field_values) - | VBottom -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + mk_apps ctx.meta cons field_values) + | VBottom -> craise __FILE__ __LINE__ ctx.meta "Unreachable" | VLoan lc -> ( match lc with | VSharedLoan (_, v) -> translate v - | VMutLoan _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" - ) + | VMutLoan _ -> craise __FILE__ __LINE__ ctx.meta "Unreachable") | VBorrow bc -> ( match bc with | VSharedBorrow bid -> (* Lookup the shared value in the context, and continue *) let sv = - InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx - bid + InterpreterBorrowsCore.lookup_shared_value ctx.meta ectx bid in translate sv | VReservedMutBorrow bid -> @@ -1615,8 +1608,7 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) * only in *meta-data*: a value *actually used* in the translation can't come * from an unpromoted reserved borrow *) let sv = - InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx - bid + InterpreterBorrowsCore.lookup_shared_value ctx.meta ectx bid in translate sv | VMutBorrow (_, v) -> @@ -1663,7 +1655,7 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert __FILE__ __LINE__ (field_values = []) ctx.fun_decl.meta + cassert __FILE__ __LINE__ (field_values = []) ctx.meta "ADTs containing borrows are not supported yet"; None | TTuple -> @@ -1672,11 +1664,9 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) else (* Note that if there is exactly one field value, * [mk_simpl_tuple_rvalue] is the identity *) - let rv = - mk_simpl_tuple_texpression ctx.fun_decl.meta field_values - in + let rv = mk_simpl_tuple_texpression ctx.meta field_values in Some rv) - | ABottom -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + | ABottom -> craise __FILE__ __LINE__ ctx.meta "Unreachable" | ALoan lc -> aloan_content_to_consumed ctx ectx lc | ABorrow bc -> aborrow_content_to_consumed ctx bc | ASymbolic aproj -> aproj_to_consumed ctx aproj @@ -1694,7 +1684,7 @@ and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (lc : V.aloan_content) : texpression option = match lc with | AMutLoan (_, _) | ASharedLoan (_, _, _) -> - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> (* Return the meta-value *) Some (typed_value_to_texpression ctx ectx given_back_meta) @@ -1706,7 +1696,7 @@ and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) None | AIgnoredMutLoan (_, _) -> (* There can be *inner* not ended mutable loans, but not outer ones *) - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" | AEndedIgnoredMutLoan _ -> (* This happens with nested borrows: we need to dive in *) raise Unimplemented @@ -1718,7 +1708,7 @@ and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : texpression option = match bc with | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - craise __FILE__ __LINE__ _ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ _ctx.meta "Unreachable" | AEndedMutBorrow (_, _) -> (* We collect consumed values: ignore *) None @@ -1737,7 +1727,7 @@ and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> sanity_check __FILE__ __LINE__ (child_aproj = AIgnoredProjBorrows) - ctx.fun_decl.meta; + ctx.meta; (* The symbolic value was updated *) Some (symbolic_value_to_texpression ctx mnv) | V.AEndedProjLoans (_, _) -> @@ -1746,7 +1736,7 @@ and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = raise Unimplemented | AEndedProjBorrows _ -> (* We consider consumed values *) None | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" (** Convert the abstraction values in an abstraction to consumed values. @@ -1812,20 +1802,20 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert __FILE__ __LINE__ (field_values = []) ctx.fun_decl.meta + cassert __FILE__ __LINE__ (field_values = []) ctx.meta "ADTs with borrows are not supported yet"; (ctx, None) | TTuple -> (* Return *) let variant_id = adt_v.variant_id in - sanity_check __FILE__ __LINE__ (variant_id = None) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (variant_id = None) ctx.meta; if field_values = [] then (ctx, None) else (* Note that if there is exactly one field value, [mk_simpl_tuple_pattern] * is the identity *) let lv = mk_simpl_tuple_pattern field_values in (ctx, Some lv)) - | ABottom -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + | ABottom -> craise __FILE__ __LINE__ ctx.meta "Unreachable" | ALoan lc -> aloan_content_to_given_back mp lc ctx | ABorrow bc -> aborrow_content_to_given_back mp bc ctx | ASymbolic aproj -> aproj_to_given_back mp aproj ctx @@ -1841,14 +1831,14 @@ and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match lc with | AMutLoan (_, _) | ASharedLoan (_, _, _) -> - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } | AEndedSharedLoan (_, _) -> (* We consider given back values, and thus ignore those *) (ctx, None) | AIgnoredMutLoan (_, _) -> (* There can be *inner* not ended mutable loans, but not outer ones *) - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" | AEndedIgnoredMutLoan _ -> (* This happens with nested borrows: we need to dive in *) raise Unimplemented @@ -1860,7 +1850,7 @@ and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match bc with | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" | AEndedMutBorrow (msv, _) -> (* Return the meta-symbolic-value *) let ctx, var = fresh_var_for_symbolic_value msv ctx in @@ -1882,14 +1872,14 @@ and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : (List.for_all (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) child_projs) - ctx.fun_decl.meta "Nested borrows are not supported yet"; + ctx.meta "Nested borrows are not supported yet"; (ctx, None) | AEndedProjBorrows mv -> (* Return the meta-value *) let ctx, var = fresh_var_for_symbolic_value mv ctx in (ctx, Some (mk_typed_pattern_from_var var mp)) | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" (** Convert the abstraction values in an abstraction to given back values. @@ -2004,7 +1994,7 @@ and translate_panic (ctx : bs_ctx) : texpression = (* Here we use the function return type - note that it is ok because * we don't match on panics which happen inside the function body - * but it won't be true anymore once we translate individual blocks *) - (* If we use a state modune partie nad, we need to add a lambda for the state variable *) + (* If we use a state monad, we need to add a lambda for the state variable *) (* Note that only forward functions return a state *) let effect_info = ctx_get_effect_info ctx in (* TODO: we should use a [Fail] function *) @@ -2013,13 +2003,13 @@ and translate_panic (ctx : bs_ctx) : texpression = (* Create the [Fail] value *) let ret_ty = mk_simpl_tuple_ty [ mk_state_ty; output_ty ] in let ret_v = - mk_result_fail_texpression_with_error_id ctx.fun_decl.meta - error_failure_id ret_ty + mk_result_fail_texpression_with_error_id ctx.meta error_failure_id + ret_ty in ret_v else - mk_result_fail_texpression_with_error_id ctx.fun_decl.meta - error_failure_id output_ty + mk_result_fail_texpression_with_error_id ctx.meta error_failure_id + output_ty in if ctx.inside_loop && Option.is_some ctx.bid then (* We are synthesizing the backward function of a loop body *) @@ -2075,12 +2065,12 @@ and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) | Some _ -> (* Backward function *) (* Sanity check *) - sanity_check __FILE__ __LINE__ (opt_v = None) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (opt_v = None) ctx.meta; (* Group the variables in which we stored the values we need to give back. See the explanations for the [SynthInput] case in [translate_end_abstraction] *) let backward_outputs = Option.get ctx.backward_outputs in let field_values = List.map mk_texpression_from_var backward_outputs in - mk_simpl_tuple_texpression ctx.fun_decl.meta field_values + mk_simpl_tuple_texpression ctx.meta field_values in (* We may need to return a state * - error-monad: Return x @@ -2090,21 +2080,17 @@ and translate_return (ectx : C.eval_ctx) (opt_v : V.typed_value option) let output = if effect_info.stateful then let state_rvalue = mk_state_texpression ctx.state_var in - mk_simpl_tuple_texpression ctx.fun_decl.meta [ state_rvalue; output ] + mk_simpl_tuple_texpression ctx.meta [ state_rvalue; output ] else output in (* Wrap in a result - TODO: check effect_info.can_fail to not always wrap *) - mk_result_return_texpression ctx.fun_decl.meta output + mk_result_return_texpression ctx.meta output and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) (ctx : bs_ctx) : texpression = - sanity_check __FILE__ __LINE__ - (is_continue = ctx.inside_loop) - ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (is_continue = ctx.inside_loop) ctx.meta; let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - sanity_check __FILE__ __LINE__ - (loop_id = Option.get ctx.loop_id) - ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (loop_id = Option.get ctx.loop_id) ctx.meta; (* Lookup the loop information *) let loop_id = Option.get ctx.loop_id in @@ -2128,7 +2114,7 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) match ctx.backward_outputs with Some outputs -> outputs | None -> [] in let field_values = List.map mk_texpression_from_var backward_outputs in - mk_simpl_tuple_texpression ctx.fun_decl.meta field_values + mk_simpl_tuple_texpression ctx.meta field_values in (* We may need to return a state @@ -2142,12 +2128,12 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) let output = if effect_info.stateful then let state_rvalue = mk_state_texpression ctx.state_var in - mk_simpl_tuple_texpression ctx.fun_decl.meta [ state_rvalue; output ] + mk_simpl_tuple_texpression ctx.meta [ state_rvalue; output ] else output in (* Wrap in a result - TODO: check effect_info.can_fail to not always wrap *) mk_emeta (Tag "return_with_loop") - (mk_result_return_texpression ctx.fun_decl.meta output) + (mk_result_return_texpression ctx.meta output) and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : texpression = @@ -2198,8 +2184,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let sg = Option.get call.sg in let decls_ctx = ctx.decls_ctx in let dsg = - translate_fun_sig_with_regions_hierarchy_to_decomposed - ctx.fun_decl.meta decls_ctx fid call.regions_hierarchy sg + translate_fun_sig_with_regions_hierarchy_to_decomposed ctx.meta + decls_ctx fid call.regions_hierarchy sg (List.map (fun _ -> None) sg.inputs) in log#ldebug @@ -2212,7 +2198,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : ctx_translate_fwd_generic_args ctx all_generics in let tr_self = - translate_fwd_trait_instance_id ctx.fun_decl.meta + translate_fwd_trait_instance_id ctx.meta ctx.type_ctx.type_infos tr_self in (tr_self, all_generics) @@ -2333,7 +2319,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : | S.Unop E.Neg -> ( match args with | [ arg ] -> - let int_ty = ty_as_integer ctx.fun_decl.meta arg.ty in + let int_ty = ty_as_integer ctx.meta arg.ty in (* Note that negation can lead to an overflow and thus fail (it * is thus monadic) *) let effect_info = @@ -2348,7 +2334,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Neg int_ty), effect_info, args, dest) - | _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") + | _ -> craise __FILE__ __LINE__ ctx.meta "Unreachable") | S.Unop (E.Cast cast_kind) -> ( match cast_kind with | CastScalar (src_ty, tgt_ty) -> @@ -2366,18 +2352,16 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, dest) | CastFnPtr _ -> - craise __FILE__ __LINE__ ctx.fun_decl.meta "TODO: function casts") + craise __FILE__ __LINE__ ctx.meta "TODO: function casts") | S.Binop binop -> ( match args with | [ arg0; arg1 ] -> - let int_ty0 = ty_as_integer ctx.fun_decl.meta arg0.ty in - let int_ty1 = ty_as_integer ctx.fun_decl.meta arg1.ty in + let int_ty0 = ty_as_integer ctx.meta arg0.ty in + let int_ty1 = ty_as_integer ctx.meta arg1.ty in (match binop with (* The Rust compiler accepts bitshifts for any integer type combination for ty0, ty1 *) | E.Shl | E.Shr -> () - | _ -> - sanity_check __FILE__ __LINE__ (int_ty0 = int_ty1) - ctx.fun_decl.meta); + | _ -> sanity_check __FILE__ __LINE__ (int_ty0 = int_ty1) ctx.meta); let effect_info = { can_fail = ExpressionsUtils.binop_can_fail binop; @@ -2390,7 +2374,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in let dest = mk_typed_pattern_from_var dest dest_mplace in (ctx, Binop (binop, int_ty0), effect_info, args, dest) - | _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") + | _ -> craise __FILE__ __LINE__ ctx.meta "Unreachable") in let func = { id = FunOrOp fun_id; generics } in let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in @@ -2399,7 +2383,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : in let func_ty = mk_arrows input_tys ret_ty in let func = { e = Qualif func; ty = func_ty } in - let call = mk_apps ctx.fun_decl.meta func args in + let call = mk_apps ctx.meta func args in (* Translate the next expression *) let next_e = translate_expression e ctx in (* Put together *) @@ -2433,7 +2417,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) ^ "\n- loop_id: " ^ Print.option_to_string Pure.LoopId.to_string ctx.loop_id ^ "\n- eval_ctx:\n" - ^ eval_ctx_to_string ~meta:(Some ctx.fun_decl.meta) ectx + ^ eval_ctx_to_string ~meta:(Some ctx.meta) ectx ^ "\n- abs:\n" ^ abs_to_string ctx abs ^ "\n")); (* When we end an input abstraction, this input abstraction gets back @@ -2447,7 +2431,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) for a parent backward function. *) let bid = Option.get ctx.bid in - sanity_check __FILE__ __LINE__ (rg_id = bid) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (rg_id = bid) ctx.meta; (* First, introduce the given back variables. @@ -2497,7 +2481,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) (fun (var, v) -> sanity_check __FILE__ __LINE__ ((var : var).ty = (v : texpression).ty) - ctx.fun_decl.meta) + ctx.meta) variables_values; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2518,7 +2502,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) | S.Fun (fun_id, _) -> fun_id | Unop _ | Binop _ -> (* Those don't have backward functions *) - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" in let effect_info = get_fun_effect_info ctx fun_id None (Some rg_id) in (* Retrieve the values consumed upon ending the loans inside this @@ -2580,7 +2564,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) ^ "\nfunc type: " ^ pure_ty_to_string ctx func.ty ^ "\n\nargs:\n" ^ String.concat "\n" args)); - let call = mk_apps ctx.fun_decl.meta func args in + let call = mk_apps ctx.meta func args in mk_let effect_info.can_fail output call next_e and translate_end_abstraction_identity (ectx : C.eval_ctx) (abs : V.abs) @@ -2591,8 +2575,8 @@ and translate_end_abstraction_identity (ectx : C.eval_ctx) (abs : V.abs) (* We can do this simply by checking that it consumes and gives back nothing *) let inputs = abs_to_consumed ctx ectx abs in let ctx, outputs = abs_to_given_back None abs ctx in - sanity_check __FILE__ __LINE__ (inputs = []) ctx.fun_decl.meta; - sanity_check __FILE__ __LINE__ (outputs = []) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (inputs = []) ctx.meta; + sanity_check __FILE__ __LINE__ (outputs = []) ctx.meta; (* Translate the next expression *) translate_expression e ctx @@ -2634,7 +2618,7 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) (* Retrieve the values consumed upon ending the loans inside this * abstraction: as there are no nested borrows, there should be none. *) let consumed = abs_to_consumed ctx ectx abs in - cassert __FILE__ __LINE__ (consumed = []) ctx.fun_decl.meta + cassert __FILE__ __LINE__ (consumed = []) ctx.meta "Nested borrows are not supported yet"; (* Retrieve the values given back upon ending this abstraction - note that * we don't provide meta-place information, because those assignments will @@ -2653,8 +2637,7 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) ^ pure_ty_to_string ctx given_back.ty ^ "\n- sig input ty: " ^ pure_ty_to_string ctx input.ty)); - sanity_check __FILE__ __LINE__ (given_back.ty = input.ty) - ctx.fun_decl.meta) + sanity_check __FILE__ __LINE__ (given_back.ty = input.ty) ctx.meta) given_back_inputs; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2671,9 +2654,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) texpression = let vloop_id = loop_id in let loop_id = V.LoopId.Map.find loop_id ctx.loop_ids_map in - sanity_check __FILE__ __LINE__ - (loop_id = Option.get ctx.loop_id) - ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (loop_id = Option.get ctx.loop_id) ctx.meta; let rg_id = Option.get rg_id in (* There are two cases depending on the [abs_kind] (whether this is a synth input or a regular loop call) *) @@ -2743,7 +2724,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) match func with | None -> next_e | Some func -> - let call = mk_apps ctx.fun_decl.meta func args in + let call = mk_apps ctx.meta func args in (* Add meta-information - this is slightly hacky: we look at the values consumed by the abstraction (note that those come from *before* we applied the fixed-point context) and use them to @@ -2800,7 +2781,7 @@ and translate_assertion (ectx : C.eval_ctx) (v : V.typed_value) in let func_ty = mk_arrow (TLiteral TBool) mk_unit_ty in let func = { e = Qualif func; ty = func_ty } in - let assertion = mk_apps ctx.fun_decl.meta func args in + let assertion = mk_apps ctx.meta func args in mk_let monadic (mk_dummy_pattern mk_unit_ty) assertion next_e and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) @@ -2815,7 +2796,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) | V.SeLiteral _ -> (* We do not *register* symbolic expansions to literal values in the symbolic ADT *) - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + craise __FILE__ __LINE__ ctx.meta "Unreachable" | SeMutRef (_, nsv) | SeSharedRef (_, nsv) -> (* The (mut/shared) borrow type is extracted to identity: we thus simply introduce an reassignment *) @@ -2828,11 +2809,11 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) next_e | SeAdt _ -> (* Should be in the [ExpandAdt] case *) - craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable") + craise __FILE__ __LINE__ ctx.meta "Unreachable") | ExpandAdt branches -> ( (* We don't do the same thing if there is a branching or not *) match branches with - | [] -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + | [] -> craise __FILE__ __LINE__ ctx.meta "Unreachable" | [ (variant_id, svl, branch) ] when not (TypesUtils.ty_is_custom_adt sv.V.sv_ty @@ -2873,7 +2854,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) (* Sanity check *) sanity_check __FILE__ __LINE__ (List.for_all (fun br -> br.branch.ty = ty) branches) - ctx.fun_decl.meta; + ctx.meta; (* Return *) { e; ty }) | ExpandBool (true_e, false_e) -> @@ -2893,7 +2874,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) ^ pure_ty_to_string ctx true_e.ty ^ "\n\nfalse_e.ty: " ^ pure_ty_to_string ctx false_e.ty)); - sanity_check __FILE__ __LINE__ (ty = false_e.ty) ctx.fun_decl.meta; + sanity_check __FILE__ __LINE__ (ty = false_e.ty) ctx.meta; { e; ty } | ExpandInt (int_ty, branches, otherwise) -> let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : @@ -2920,7 +2901,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) let ty = otherwise.branch.ty in sanity_check __FILE__ __LINE__ (List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) - ctx.fun_decl.meta; + ctx.meta; { e; ty } (* Translate and [ExpandAdt] when there is no branching (i.e., one branch). @@ -2995,14 +2976,14 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) * field. * We use the [dest] variable in order not to have to recompute * the type of the result of the projection... *) - let adt_id, generics = ty_as_adt ctx.fun_decl.meta scrutinee.ty in + let adt_id, generics = ty_as_adt ctx.meta scrutinee.ty in let gen_field_proj (field_id : FieldId.id) (dest : var) : texpression = let proj_kind = { adt_id; field_id } in let qualif = { id = Proj proj_kind; generics } in let proj_e = Qualif qualif in let proj_ty = mk_arrow scrutinee.ty dest.ty in let proj = { e = proj_e; ty = proj_ty } in - mk_app ctx.fun_decl.meta proj scrutinee + mk_app ctx.meta proj scrutinee in let id_var_pairs = FieldId.mapi (fun fid v -> (fid, v)) vars in let monadic = false in @@ -3023,7 +3004,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) let var = match vars with | [ v ] -> v - | _ -> craise __FILE__ __LINE__ ctx.fun_decl.meta "Unreachable" + | _ -> craise __FILE__ __LINE__ ctx.meta "Unreachable" in (* We simply introduce an assignment - the box type is the * identity when extracted ([box a = a]) *) @@ -3037,7 +3018,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number * of fields!) *) - craise __FILE__ __LINE__ ctx.fun_decl.meta + craise __FILE__ __LINE__ ctx.meta "Attempt to expand a non-expandable value" and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) @@ -3075,9 +3056,7 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) | VaCgValue cg_id -> { e = CVar cg_id; ty = var.ty } | VaTraitConstValue (trait_ref, const_name) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = - translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref - in + let trait_ref = translate_fwd_trait_ref ctx.meta type_infos trait_ref in let qualif_id = TraitConst (trait_ref, const_name) in let qualif = { id = qualif_id; generics = empty_generic_args } in { e = Qualif qualif; ty = var.ty } @@ -3218,7 +3197,7 @@ and translate_forward_end (ectx : C.eval_ctx) else pure_fwd_var :: back_vars in let vars = List.map mk_texpression_from_var vars in - let ret = mk_simpl_tuple_texpression ctx.fun_decl.meta vars in + let ret = mk_simpl_tuple_texpression ctx.meta vars in (* Introduce a fresh input state variable for the forward expression *) let _ctx, state_var, state_pat = @@ -3229,10 +3208,8 @@ and translate_forward_end (ectx : C.eval_ctx) in let state_var = List.map mk_texpression_from_var state_var in - let ret = - mk_simpl_tuple_texpression ctx.fun_decl.meta (state_var @ [ ret ]) - in - let ret = mk_result_return_texpression ctx.fun_decl.meta ret in + let ret = mk_simpl_tuple_texpression ctx.meta (state_var @ [ ret ]) in + let ret = mk_result_return_texpression ctx.meta ret in (* Introduce all the let-bindings *) @@ -3405,7 +3382,7 @@ and translate_forward_end (ectx : C.eval_ctx) in let func_ty = mk_arrows input_tys ret_ty in let func = { e = Qualif func; ty = func_ty } in - let call = mk_apps ctx.fun_decl.meta func args in + let call = mk_apps ctx.meta func args in call in @@ -3464,7 +3441,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (fun (sv : V.symbolic_value) -> V.SymbolicValueId.Map.mem sv.sv_id ctx.sv_to_var) loop.input_svalues) - ctx.fun_decl.meta; + ctx.meta; (* Translate the loop inputs *) let inputs = @@ -3486,7 +3463,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (fun ty -> cassert __FILE__ __LINE__ (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)) - !ctx.fun_decl.meta "The types shouldn't contain borrows"; + !ctx.meta "The types shouldn't contain borrows"; ctx_translate_fwd_ty !ctx ty) tys) loop.rg_to_given_back_tys @@ -3567,7 +3544,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = let ctx = sanity_check __FILE__ __LINE__ (not (LoopId.Map.mem loop_id ctx.loops)) - ctx.fun_decl.meta; + ctx.meta; (* Note that we will retrieve the input values later in the [ForwardEnd] (and will introduce the outputs at that moment, together with the actual diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 4c0f2e0d..348183c5 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -127,6 +127,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) let ctx = { + meta = fdef.meta; decls_ctx = trans_ctx; SymbolicToPure.bid = None; sg; -- cgit v1.2.3