From e5824d50f9616c0d6d174814ad673924c5660f82 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Thu, 30 Jan 2025 11:11:30 +0100 Subject: [PATCH 01/21] Revert "New test snapshot." This reverts commit 53fa1a0c969dc36c26edc58c26009cd8c6b2360c. --- .../src/snapshots/toolchain__cyclic-modules into-fstar.snap | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap b/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap index 077c9eb31..d5ef39ba1 100644 --- a/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap @@ -299,8 +299,6 @@ module Cyclic_modules.Moved_trait open Core open FStar.Mul -include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {impl as impl} - include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {v_Tr as v_Tr} include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {f_f_pre as f_f_pre} @@ -308,6 +306,8 @@ include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {f_f_pre as f_f_pre} include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {f_f_post as f_f_post} include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {f_f as f_f} + +include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {impl as impl} ''' "Cyclic_modules.Rec.fst" = ''' module Cyclic_modules.Rec From b5bceaf225cd643398dbd0538c70b837ed5406f3 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Thu, 30 Jan 2025 11:11:41 +0100 Subject: [PATCH 02/21] Revert "Rename trait methods in bundles for all backends, but include them only for fstar (hack)." This reverts commit 15ca9770dc00957debf3a6f7aa602424326bee66. --- engine/backends/fstar/fstar_backend.ml | 3 -- engine/lib/dependencies.ml | 28 ++++----------- engine/lib/dependencies.mli | 4 --- .../toolchain__cyclic-modules into-fstar.snap | 34 +++++++++---------- 4 files changed, 23 insertions(+), 46 deletions(-) diff --git a/engine/backends/fstar/fstar_backend.ml b/engine/backends/fstar/fstar_backend.ml index fe956b435..dc01e4cbd 100644 --- a/engine/backends/fstar/fstar_backend.ml +++ b/engine/backends/fstar/fstar_backend.ml @@ -1865,9 +1865,6 @@ let apply_phases (bo : BackendOptions.t) (items : Ast.Rust.item list) : (* else *) items in - (* This is a hack that should be removed - (see https://github.com/hacspec/hax/issues/1078) *) - Dependencies.includes_for_bundled_trait_methods := true; let items = TransformToInputLanguage.ditems items |> List.map ~f:unsize_as_identity diff --git a/engine/lib/dependencies.ml b/engine/lib/dependencies.ml index aecdec51f..1b458e189 100644 --- a/engine/lib/dependencies.ml +++ b/engine/lib/dependencies.ml @@ -1,9 +1,5 @@ open! Prelude -(** This is a hack that should be removed - (see https://github.com/hacspec/hax/issues/1078) *) -let includes_for_bundled_trait_methods = ref false - module Make (F : Features.T) = struct module AST = Ast.Make (F) module U = Ast_utils.Make (F) @@ -565,8 +561,7 @@ module Make (F : Features.T) = struct ( name, Concrete_ident.Create.move_under ~new_parent:new_name name ))) - | Some { v = Trait { items; _ }; _ } - when !includes_for_bundled_trait_methods -> + | Some { v = Trait { items; _ }; _ } -> List.map items ~f:(fun { ti_ident; _ } -> ( ti_ident, Concrete_ident.Create.move_under ~new_parent:new_name ti_ident @@ -576,22 +571,11 @@ module Make (F : Features.T) = struct let variant_and_constructors_renamings = List.concat_map ~f:variants_renamings renamings |> List.concat_map ~f:(fun (old_name, new_name) -> - let trait_methods_renamings = - match from_ident old_name with - | Some { v = Trait { items; _ }; _ } - when not !includes_for_bundled_trait_methods -> - List.map items ~f:(fun { ti_ident; _ } -> - ( ti_ident, - Concrete_ident.Create.move_under ~new_parent:new_name - ti_ident )) - | _ -> [] - in - trait_methods_renamings - @ [ - (old_name, new_name); - ( Concrete_ident.Create.constructor old_name, - Concrete_ident.Create.constructor new_name ); - ]) + [ + (old_name, new_name); + ( Concrete_ident.Create.constructor old_name, + Concrete_ident.Create.constructor new_name ); + ]) in let renamings = match diff --git a/engine/lib/dependencies.mli b/engine/lib/dependencies.mli index ccb14ffce..c4ba68881 100644 --- a/engine/lib/dependencies.mli +++ b/engine/lib/dependencies.mli @@ -9,7 +9,3 @@ module Make (F : Features.T) : sig val filter_by_inclusion_clauses : Types.inclusion_clause list -> AST.item list -> AST.item list end - -val includes_for_bundled_trait_methods : bool ref -(** This is a hack that should be removed - (see https://github.com/hacspec/hax/issues/1078) *) diff --git a/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap b/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap index d5ef39ba1..3c32e55a4 100644 --- a/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap @@ -259,8 +259,18 @@ include Cyclic_modules.M1.Cyclic_bundle_892895908 {b as b} include Cyclic_modules.M1.Cyclic_bundle_892895908 {c as c} ''' -"Cyclic_modules.Moved_trait.Cyclic_bundle_202498800.fst" = ''' -module Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 +"Cyclic_modules.Moved_trait.Nested.fst" = ''' +module Cyclic_modules.Moved_trait.Nested +#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" +open Core +open FStar.Mul + +include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {t_St as t_St} + +include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {g as g} +''' +"Cyclic_modules.Moved_trait.Rec_bundle_963167032.fst" = ''' +module Cyclic_modules.Moved_trait.Rec_bundle_963167032 #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul @@ -283,31 +293,21 @@ let impl: v_Tr t_St = let g (x: t_St) : Prims.unit = f_f #t_St #FStar.Tactics.Typeclasses.solve x ''' -"Cyclic_modules.Moved_trait.Nested.fst" = ''' -module Cyclic_modules.Moved_trait.Nested -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {t_St as t_St} - -include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {g as g} -''' "Cyclic_modules.Moved_trait.fst" = ''' module Cyclic_modules.Moved_trait #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {v_Tr as v_Tr} +include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {v_Tr as v_Tr} -include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {f_f_pre as f_f_pre} +include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {f_f_pre as f_f_pre} -include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {f_f_post as f_f_post} +include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {f_f_post as f_f_post} -include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {f_f as f_f} +include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {f_f as f_f} -include Cyclic_modules.Moved_trait.Cyclic_bundle_202498800 {impl as impl} +include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {impl as impl} ''' "Cyclic_modules.Rec.fst" = ''' module Cyclic_modules.Rec From 5530d5a69728f3f538d7ec7f2cc7cc524799d6a4 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Thu, 30 Jan 2025 11:11:49 +0100 Subject: [PATCH 03/21] Revert "Move trait methods in cyclic dependencies bundling." This reverts commit 43829c4f115ae31932a11c7657e48332ef2f2f45. --- engine/lib/dependencies.ml | 5 -- .../toolchain__cyclic-modules into-fstar.snap | 50 ------------------- tests/cyclic-modules/src/lib.rs | 17 ------- 3 files changed, 72 deletions(-) diff --git a/engine/lib/dependencies.ml b/engine/lib/dependencies.ml index 1b458e189..e314571a1 100644 --- a/engine/lib/dependencies.ml +++ b/engine/lib/dependencies.ml @@ -561,11 +561,6 @@ module Make (F : Features.T) = struct ( name, Concrete_ident.Create.move_under ~new_parent:new_name name ))) - | Some { v = Trait { items; _ }; _ } -> - List.map items ~f:(fun { ti_ident; _ } -> - ( ti_ident, - Concrete_ident.Create.move_under ~new_parent:new_name ti_ident - )) | _ -> [] in let variant_and_constructors_renamings = diff --git a/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap b/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap index 3c32e55a4..e3ef061c7 100644 --- a/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap @@ -259,56 +259,6 @@ include Cyclic_modules.M1.Cyclic_bundle_892895908 {b as b} include Cyclic_modules.M1.Cyclic_bundle_892895908 {c as c} ''' -"Cyclic_modules.Moved_trait.Nested.fst" = ''' -module Cyclic_modules.Moved_trait.Nested -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {t_St as t_St} - -include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {g as g} -''' -"Cyclic_modules.Moved_trait.Rec_bundle_963167032.fst" = ''' -module Cyclic_modules.Moved_trait.Rec_bundle_963167032 -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -class v_Tr (v_Self: Type0) = { - f_f_pre:v_Self -> Type0; - f_f_post:v_Self -> Prims.unit -> Type0; - f_f:x0: v_Self -> Prims.Pure Prims.unit (f_f_pre x0) (fun result -> f_f_post x0 result) -} - -type t_St = | St : t_St - -[@@ FStar.Tactics.Typeclasses.tcinstance] -let impl: v_Tr t_St = - { - f_f_pre = (fun (self: t_St) -> true); - f_f_post = (fun (self: t_St) (out: Prims.unit) -> true); - f_f = fun (self: t_St) -> () - } - -let g (x: t_St) : Prims.unit = f_f #t_St #FStar.Tactics.Typeclasses.solve x -''' -"Cyclic_modules.Moved_trait.fst" = ''' -module Cyclic_modules.Moved_trait -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {v_Tr as v_Tr} - -include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {f_f_pre as f_f_pre} - -include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {f_f_post as f_f_post} - -include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {f_f as f_f} - -include Cyclic_modules.Moved_trait.Rec_bundle_963167032 {impl as impl} -''' "Cyclic_modules.Rec.fst" = ''' module Cyclic_modules.Rec #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" diff --git a/tests/cyclic-modules/src/lib.rs b/tests/cyclic-modules/src/lib.rs index cb45f7b82..216a54812 100644 --- a/tests/cyclic-modules/src/lib.rs +++ b/tests/cyclic-modules/src/lib.rs @@ -178,20 +178,3 @@ pub mod late_skip_b { super::late_skip_a::f() } } - -pub mod moved_trait { - impl Tr for nested::St { - fn f(self) {} - } - pub trait Tr { - fn f(self); - } - - pub mod nested { - use super::Tr; - pub struct St {} - fn g(x: St) { - x.f() - } - } -} From 7fe83d670e285c60240f1454aa49e7ad43aa2d53 Mon Sep 17 00:00:00 2001 From: Lucas Franceschino Date: Tue, 10 Dec 2024 16:39:48 +0100 Subject: [PATCH 04/21] feat(ocaml): derive more for types --- .../ocaml_of_json_schema.js | 33 ++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/engine/utils/ocaml_of_json_schema/ocaml_of_json_schema.js b/engine/utils/ocaml_of_json_schema/ocaml_of_json_schema.js index 3a9b866b4..92825b158 100644 --- a/engine/utils/ocaml_of_json_schema/ocaml_of_json_schema.js +++ b/engine/utils/ocaml_of_json_schema/ocaml_of_json_schema.js @@ -534,6 +534,36 @@ function run(str) { let sig = ``; let impl = `include struct +open struct + include Base.Hash.Builtin + open Base + let bool_of_sexp = bool_of_sexp + let string_of_sexp = string_of_sexp + let option_of_sexp = option_of_sexp + let list_of_sexp = list_of_sexp + let int_of_sexp = int_of_sexp + let char_of_sexp = char_of_sexp + let unit_of_sexp = unit_of_sexp + let bool_of_sexp = bool_of_sexp + + let sexp_of_bool = sexp_of_bool + let sexp_of_string = sexp_of_string + let sexp_of_option = sexp_of_option + let sexp_of_list = sexp_of_list + let sexp_of_int = sexp_of_int + let sexp_of_char = sexp_of_char + let sexp_of_unit = sexp_of_unit + let sexp_of_bool = sexp_of_bool + + let compare_bool = compare_bool + let compare_string = compare_string + let compare_option = compare_option + let compare_list = compare_list + let compare_int = compare_int + let compare_char = compare_char + let compare_unit = compare_unit + let compare_bool = compare_bool +end [@@@warning "-A"] `; @@ -546,7 +576,7 @@ function run(str) { ([name, def]) => export_definition(name, def) ).filter(x => x instanceof Object); - let derive_items = ['show', 'eq']; + let derive_items = ['show', 'eq', 'hash', 'sexp', 'compare']; impl += ` module ParseError = struct @@ -578,6 +608,7 @@ open ParseError and node_for__ty_kind = node_for_ty_kind_generated and node_for__def_id_contents = node_for_def_id_contents_generated + type map_types = ${"[`TyKind of ty_kind | `DefIdContents of def_id_contents]"} let cache_map: (int64, ${"[ `Value of map_types | `JSON of Yojson.Safe.t ]"}) Base.Hashtbl.t = Base.Hashtbl.create (module Base.Int64) From 9661926e7f22c924c3806207fe14d270043705f7 Mon Sep 17 00:00:00 2001 From: Lucas Franceschino Date: Wed, 18 Dec 2024 15:35:43 +0100 Subject: [PATCH 05/21] Complete redesign of concrete identifiers --- engine/backends/coq/coq/coq_backend.ml | 16 +- .../backends/coq/ssprove/ssprove_backend.ml | 30 +- .../backends/easycrypt/easycrypt_backend.ml | 18 +- engine/backends/fstar/fstar_backend.ml | 101 +- engine/backends/proverif/proverif_backend.ml | 7 +- engine/bin/lib.ml | 2 +- engine/lib/analyses/function_dependency.ml | 5 +- engine/lib/analyses/mutable_variables.ml | 20 +- engine/lib/ast.ml | 2 +- engine/lib/ast_builder.ml | 17 +- engine/lib/ast_utils.ml | 52 +- engine/lib/concrete_ident/concrete_ident.ml | 1215 +++++++++-------- engine/lib/concrete_ident/concrete_ident.mli | 143 +- .../concrete_ident_render_sig.ml | 30 + .../lib/concrete_ident/concrete_ident_sig.ml | 32 - .../concrete_ident/concrete_ident_types.ml | 75 + .../lib/concrete_ident/concrete_ident_view.ml | 202 +++ .../concrete_ident/concrete_ident_view.mli | 4 + .../concrete_ident_view_types.ml | 214 +++ engine/lib/concrete_ident/explicit_def_id.ml | 127 ++ engine/lib/concrete_ident/explicit_def_id.mli | 83 ++ engine/lib/concrete_ident/impl_infos.ml | 2 +- .../lib/concrete_ident/thir_simple_types.ml | 78 ++ engine/lib/dependencies.ml | 250 ++-- .../deprecated_generic_printer.ml | 13 +- .../deprecated_generic_printer.mli | 2 +- engine/lib/dune | 14 + engine/lib/generic_printer/generic_printer.ml | 23 +- engine/lib/import_thir.ml | 163 +-- engine/lib/phases/phase_cf_into_monads.ml | 11 +- engine/lib/phases/phase_direct_and_mut.ml | 3 +- engine/lib/phases/phase_drop_match_guards.ml | 5 +- .../phase_drop_return_break_continue.ml | 2 +- .../lib/phases/phase_functionalize_loops.ml | 12 +- .../lib/phases/phase_reconstruct_asserts.ml | 5 +- .../phase_reconstruct_question_marks.ml | 5 +- .../phases/phase_simplify_question_marks.ml | 17 +- engine/lib/phases/phase_specialize.ml | 2 +- engine/lib/phases/phase_traits_specs.ml | 11 +- engine/lib/print_rust.ml | 46 +- engine/lib/utils.ml | 31 + engine/names/src/lib.rs | 5 +- .../ocaml_of_json_schema.js | 20 +- flake.nix | 3 +- 44 files changed, 1928 insertions(+), 1190 deletions(-) create mode 100644 engine/lib/concrete_ident/concrete_ident_render_sig.ml delete mode 100644 engine/lib/concrete_ident/concrete_ident_sig.ml create mode 100644 engine/lib/concrete_ident/concrete_ident_types.ml create mode 100644 engine/lib/concrete_ident/concrete_ident_view.ml create mode 100644 engine/lib/concrete_ident/concrete_ident_view.mli create mode 100644 engine/lib/concrete_ident/concrete_ident_view_types.ml create mode 100644 engine/lib/concrete_ident/explicit_def_id.ml create mode 100644 engine/lib/concrete_ident/explicit_def_id.mli create mode 100644 engine/lib/concrete_ident/thir_simple_types.ml diff --git a/engine/backends/coq/coq/coq_backend.ml b/engine/backends/coq/coq/coq_backend.ml index 93e386c7d..88f135544 100644 --- a/engine/backends/coq/coq/coq_backend.ml +++ b/engine/backends/coq/coq/coq_backend.ml @@ -68,7 +68,8 @@ module AST = Ast.Make (InputLanguage) module BackendOptions = Backend.UnitBackendOptions open Ast module CoqNamePolicy = Concrete_ident.DefaultNamePolicy -module U = Ast_utils.MakeWithNamePolicy (InputLanguage) (CoqNamePolicy) +module U = Ast_utils.Make (InputLanguage) +module RenderId = Concrete_ident.MakeRenderAPI (CoqNamePolicy) open AST let hardcoded_coq_headers = @@ -492,7 +493,7 @@ struct let crate = String.capitalize (Option.value ~default:"(TODO CRATE)" - (Option.map ~f:fst current_namespace)) + (Option.bind ~f:List.hd current_namespace)) in let concat_capitalize l = String.concat ~sep:"_" (List.map ~f:String.capitalize l) @@ -509,7 +510,7 @@ struct (crate :: List.drop_last_exn (Option.value ~default:[] - (Option.map ~f:snd current_namespace)) + (Option.bind ~f:List.tl current_namespace)) @ xs) | [ a ] -> a | xs -> concat_capitalize_include xs @@ -729,7 +730,7 @@ struct method concrete_ident ~local:_ id : document = string - (match id.definition with + (match id.name with | "not" -> "negb" | "eq" -> "t_PartialEq_f_eq" | "lt" -> "t_PartialOrd_f_lt" @@ -765,12 +766,13 @@ let translate m _ ~bundles:_ (items : AST.item list) : Types.file list = let my_printer = make m in U.group_items_by_namespace items |> Map.to_alist + |> List.filter_map ~f:(fun (_, items) -> + let* first_item = List.hd items in + Some ((RenderId.render first_item.ident).path, items)) |> List.map ~f:(fun (ns, items) -> let mod_name = String.concat ~sep:"_" - (List.map - ~f:(map_first_letter String.uppercase) - (fst ns :: snd ns)) + (List.map ~f:(map_first_letter String.uppercase) ns) in let sourcemap, contents = let annotated = my_printer#entrypoint_modul items in diff --git a/engine/backends/coq/ssprove/ssprove_backend.ml b/engine/backends/coq/ssprove/ssprove_backend.ml index ae3667889..dcba31b8d 100644 --- a/engine/backends/coq/ssprove/ssprove_backend.ml +++ b/engine/backends/coq/ssprove/ssprove_backend.ml @@ -74,7 +74,8 @@ module AST = Ast.Make (InputLanguage) module BackendOptions = Backend.UnitBackendOptions open Ast module CoqNamePolicy = Concrete_ident.DefaultNamePolicy -module U = Ast_utils.MakeWithNamePolicy (InputLanguage) (CoqNamePolicy) +module U = Ast_utils.Make (InputLanguage) +module RenderId = Concrete_ident.MakeRenderAPI (CoqNamePolicy) open AST module SSProveLibrary : Library = struct @@ -553,7 +554,7 @@ end module Context = struct type t = { - current_namespace : string * string list; + current_namespace : string list; analysis_data : StaticAnalysis.analysis_data; } end @@ -618,10 +619,10 @@ module TransformToInputLanguage (* : PHASE *) = (* | None -> Error.unimplemented ~details:err span *) let pconcrete_ident (id : Ast.concrete_ident) : string = - U.Concrete_ident_view.to_definition_name id + (RenderId.render id).name let plocal_ident (e : Local_ident.t) : string = - U.Concrete_ident_view.local_ident + RenderId.local_ident (match String.chop_prefix ~prefix:"impl " e.name with | Some name -> let name = "impl_" ^ Int.to_string ([%hash: string] name) in @@ -690,7 +691,7 @@ struct | Bool b -> SSP.AST.Const_bool b let operators = - let c = Ast.Global_ident.of_name Value in + let c = Ast.Global_ident.of_name ~value:true in [ (c Rust_primitives__hax__array_of_list, (3, [ ""; ".a["; "]<-"; "" ])); (c Core__ops__index__Index__index, (2, [ ""; ".a["; "]" ])); @@ -1556,8 +1557,8 @@ struct let id = [%show: concrete_ident] macro in Error.raise { kind = UnsupportedMacro { id }; span = e.span } in - match U.Concrete_ident_view.to_view macro with - | { crate = "hacspec_lib"; path = _; definition = name } -> ( + match RenderId.render macro with + | { path = "hacspec_lib" :: _; name } -> ( match name with | "public_nat_mod" -> let open Hacspeclib_macro_parser in @@ -1713,7 +1714,7 @@ struct | _ -> unsupported ()) | _ -> unsupported ()) | Use { path; is_external; rename } -> - let _ns_crate, _ns_path = ctx.current_namespace in + let _ns_path = ctx.current_namespace in if is_external then [] else [ SSP.AST.Require (None, (* ns_crate:: ns_path @ *) path, rename) ] @@ -1989,10 +1990,7 @@ let print_item (analysis_data : StaticAnalysis.analysis_data) (item : AST.item) : SSP.AST.decl list = let (module Print) = make - { - current_namespace = U.Concrete_ident_view.to_namespace item.ident; - analysis_data; - } + { current_namespace = (RenderId.render item.ident).path; analysis_data } in Print.pitem item @@ -2422,12 +2420,14 @@ let translate _ (_bo : BackendOptions.t) ~(bundles : AST.item list list) let analysis_data = StaticAnalysis.analyse items in U.group_items_by_namespace items |> Map.to_alist + |> List.filter_map + ~f: + (snd >> List.hd + >> Option.map ~f:(fun i -> ((RenderId.render i.ident).path, items))) |> List.map ~f:(fun (ns, items) -> let mod_name = String.concat ~sep:"_" - (List.map - ~f:(map_first_letter String.uppercase) - (fst ns :: snd ns)) + (List.map ~f:(map_first_letter String.uppercase) ns) in let file_content = hardcoded_coq_headers ^ "\n" diff --git a/engine/backends/easycrypt/easycrypt_backend.ml b/engine/backends/easycrypt/easycrypt_backend.ml index 6b138c8be..af90ff9a2 100644 --- a/engine/backends/easycrypt/easycrypt_backend.ml +++ b/engine/backends/easycrypt/easycrypt_backend.ml @@ -22,7 +22,8 @@ include module BackendOptions = Backend.UnitBackendOptions module AST = Ast.Make (InputLanguage) module ECNamePolicy = Concrete_ident.DefaultNamePolicy -module U = Ast_utils.MakeWithNamePolicy (InputLanguage) (ECNamePolicy) +module U = Ast_utils.Make (InputLanguage) +module RenderId = Concrete_ident.MakeRenderAPI (ECNamePolicy) open AST module RejectNotEC (FA : Features.T) = struct @@ -88,14 +89,11 @@ module NM = struct { the with subnms = Map.Poly.update ~f:update the.subnms name } - let push_using_namespace (the : nmtree) (nm : string * string list) - (item : AST.item) = - push_using_longname the (List.rev (fst nm :: snd nm)) item + let push_using_namespace (the : nmtree) (nm : string list) (item : AST.item) = + push_using_longname the (List.rev nm) item let push (the : nmtree) (item : AST.item) = - push_using_namespace the - (U.Concrete_ident_view.to_namespace item.ident) - item + push_using_namespace the (RenderId.render item.ident).path item end let suffix_of_size (size : Ast.size) = @@ -132,7 +130,7 @@ let translate' (_bo : BackendOptions.t) (items : AST.item list) : match item.v with | Fn { name; generics; body; params } when List.is_empty generics.params -> - let name = U.Concrete_ident_view.to_definition_name name in + let name = (RenderId.render name).name in doit_fn fmt (name, params, body) | Fn _ -> assert false @@ -166,7 +164,7 @@ let translate' (_bo : BackendOptions.t) (items : AST.item list) : pp_param) params doit_stmt body and doit_concrete_ident (fmt : Formatter.t) (p : Concrete_ident.t) = - Stdlib.Format.fprintf fmt "%s" (U.Concrete_ident_view.to_definition_name p) + Stdlib.Format.fprintf fmt "%s" (RenderId.render p).name and doit_type (fmt : Formatter.t) (typ : ty) = match typ with | TBool -> assert false @@ -281,7 +279,7 @@ let translate' (_bo : BackendOptions.t) (items : AST.item list) : || eq_name Core__cmp__PartialEq__ne op || eq_name Core__cmp__PartialEq__eq op) -> Stdlib.Format.fprintf fmt "(%a) %s (%a)" doit_expr e1 - (match U.Concrete_ident_view.to_definition_name op with + (match (RenderId.render op).name with | "bitxor" -> "^" | "bitand" -> "&" | "bitor" -> "|" diff --git a/engine/backends/fstar/fstar_backend.ml b/engine/backends/fstar/fstar_backend.ml index dc01e4cbd..e24625420 100644 --- a/engine/backends/fstar/fstar_backend.ml +++ b/engine/backends/fstar/fstar_backend.ml @@ -79,19 +79,20 @@ module FStarNamePolicy = struct [@@@ocamlformat "disable"] - let index_field_transform index = "_" ^ index + let anonymous_field_transform index = "_" ^ index let reserved_words = Hash_set.of_list (module String) ["attributes";"noeq";"unopteq";"and";"assert";"assume";"begin";"by";"calc";"class";"default";"decreases";"effect";"eliminate";"else";"end";"ensures";"exception";"exists";"false";"friend";"forall";"fun";"λ";"function";"if";"in";"include";"inline";"inline_for_extraction";"instance";"introduce";"irreducible";"let";"logic";"match";"returns";"as";"module";"new";"new_effect";"layered_effect";"polymonadic_bind";"polymonadic_subcomp";"noextract";"of";"open";"opaque";"private";"quote";"range_of";"rec";"reifiable";"reify";"reflectable";"requires";"set_range_of";"sub_effect";"synth";"then";"total";"true";"try";"type";"unfold";"unfoldable";"val";"when";"with";"_";"__SOURCE_FILE__";"__LINE__";"match";"if";"let";"and";"string"] end -module U = Ast_utils.MakeWithNamePolicy (InputLanguage) (FStarNamePolicy) +module RenderId = Concrete_ident.MakeRenderAPI (FStarNamePolicy) +module U = Ast_utils.Make (InputLanguage) module Visitors = Ast_visitors.Make (InputLanguage) open AST module F = Fstar_ast module Context = struct type t = { - current_namespace : string * string list; + current_namespace : string list; items : item list; interface_mode : bool; line_width : int; @@ -99,9 +100,8 @@ module Context = struct end (** Convers a namespace to a module name *) -let module_name (ns : string * string list) : string = - String.concat ~sep:"." - (List.map ~f:(map_first_letter String.uppercase) (fst ns :: snd ns)) +let module_name (ns : string list) : string = + String.concat ~sep:"." (List.map ~f:(map_first_letter String.uppercase) ns) module Make (Attrs : Attrs.WITH_ITEMS) @@ -222,11 +222,10 @@ struct | _ -> mk_const @@ pliteral_as_const span e let pconcrete_ident (id : concrete_ident) = - let id = U.Concrete_ident_view.to_view id in - let ns_crate, ns_path = ctx.current_namespace in - if String.(ns_crate = id.crate) && [%eq: string list] ns_path id.path then - F.lid [ id.definition ] - else F.lid (id.crate :: (id.path @ [ id.definition ])) + let id = RenderId.render id in + let path = ctx.current_namespace in + if [%eq: string list] path id.path then F.lid [ id.name ] + else F.lid (id.path @ [ id.name ]) let rec pglobal_ident (span : span) (id : global_ident) = match id with @@ -253,7 +252,7 @@ struct ^ show_global_ident id) let plocal_ident_str (e : Local_ident.t) = - U.Concrete_ident_view.local_ident + RenderId.local_ident (match String.chop_prefix ~prefix:"impl " e.name with | Some name -> let name = "impl_" ^ Int.to_string ([%hash: string] name) in @@ -274,8 +273,7 @@ struct ^ show_global_ident f) let index_of_field_concrete id = - try Some (Int.of_string @@ U.Concrete_ident_view.to_definition_name id) - with _ -> None + try Some (Int.of_string @@ (RenderId.render id).name) with _ -> None let index_of_field = function | `Concrete id -> index_of_field_concrete id @@ -285,7 +283,7 @@ struct let is_field_an_index = index_of_field >> Option.is_some let operators = - let c = Global_ident.of_name Value in + let c = Global_ident.of_name ~value:true in [ (c Rust_primitives__hax__array_of_list, (3, ".[]<-")); (c Core__ops__index__Index__index, (2, ".[]")); @@ -355,14 +353,11 @@ struct F.mk_e_app (F.term_of_lid [ "t_Array" ]) [ pty span typ; pexpr length ] | TParam i -> F.term @@ F.AST.Var (F.lid_of_id @@ plocal_ident i) | TAssociatedType { impl = { kind = Self; _ }; item } -> - F.term - @@ F.AST.Var (F.lid [ U.Concrete_ident_view.to_definition_name item ]) + F.term @@ F.AST.Var (F.lid [ (RenderId.render item).name ]) | TAssociatedType { impl; item } -> ( match pimpl_expr span impl with | Some impl -> - F.term - @@ F.AST.Project - (impl, F.lid [ U.Concrete_ident_view.to_definition_name item ]) + F.term @@ F.AST.Project (impl, F.lid [ (RenderId.render item).name ]) | None -> F.term @@ F.AST.Wild) | TOpaque s -> F.term @@ F.AST.Wild | TDyn { goals; _ } -> @@ -567,7 +562,8 @@ struct let body = F.AST.mkConsList F.dummyRange (List.map ~f:pexpr l) in let array_of_list = let id = - Concrete_ident.of_name Value Rust_primitives__hax__array_of_list + Concrete_ident.of_name ~value:true + Rust_primitives__hax__array_of_list in F.term @@ F.AST.Name (pconcrete_ident id) in @@ -934,16 +930,15 @@ struct | Alias { name; item } -> (* These should come from bundled items (in the case of cyclic module dependencies). We make use of this f* feature: https://github.com/FStarLang/FStar/pull/3369 *) - let bundle = U.Concrete_ident_view.to_namespace item |> module_name in + let bundle = (RenderId.render item).path |> module_name in [ `VerbatimImpl ( Printf.sprintf "include %s {%s as %s}" bundle - (U.Concrete_ident_view.to_definition_name item) - (U.Concrete_ident_view.to_definition_name name), + (RenderId.render item).name (RenderId.render name).name, `Newline ); ] | Fn { name; generics; body; params } -> - let name = F.id @@ U.Concrete_ident_view.to_definition_name name in + let name = F.id @@ (RenderId.render name).name in let pat = F.pat @@ F.AST.PatVar (name, None, []) in let generics = FStarBinder.of_generics e.span generics in let pat_args = @@ -975,7 +970,7 @@ struct let name = match pat.p with | PBinding { var; _ } -> - Some (U.Concrete_ident_view.local_ident var) + Some (RenderId.local_ident var) | _ -> (* TODO: this might generate bad code, see @@ -1004,9 +999,7 @@ struct else full | TyAlias { name; generics; ty } -> let pat = - F.pat - @@ F.AST.PatVar - (F.id @@ U.Concrete_ident_view.to_definition_name name, None, []) + F.pat @@ F.AST.PatVar (F.id @@ (RenderId.render name).name, None, []) in let ty, quals = (* Adds a refinement if a refinement attribute is detected *) @@ -1044,7 +1037,7 @@ struct F.term @@ F.AST.Product (List.map ~f:FStarBinder.to_binder generics, ty) in - let name = F.id @@ U.Concrete_ident_view.to_definition_name name in + let name = F.id @@ (RenderId.render name).name in let erased = erased_impl name arrow_typ [] generics in let intf = F.decl ~fsti:true (F.AST.Val (name, arrow_typ)) in if ctx.interface_mode then intf :: erased else erased @@ -1061,7 +1054,7 @@ struct false, [ F.AST.TyconRecord - ( F.id @@ U.Concrete_ident_view.to_definition_name name, + ( F.id @@ (RenderId.render name).name, FStarBinder.of_generics e.span generics |> List.map ~f:FStarBinder.implicit_to_explicit |> List.map ~f:FStarBinder.to_binder, @@ -1069,12 +1062,10 @@ struct [], List.map ~f:(fun (prev, (field, ty, attrs)) -> - let fname : string = - U.Concrete_ident_view.to_definition_name field - in + let fname : string = (RenderId.render field).name in let fvars = List.map prev ~f:(fun (field, _, _) -> - U.Concrete_ident_view.to_definition_name field) + (RenderId.render field).name) in ( F.id fname, None, @@ -1085,7 +1076,7 @@ struct | Type { name; generics; variants; _ } -> let self = F.mk_e_app - (F.term_of_lid [ U.Concrete_ident_view.to_definition_name name ]) + (F.term_of_lid [ (RenderId.render name).name ]) (List.map ~f:FStarBinder.(of_generic_param e.span >> to_ident) generics.params @@ -1095,7 +1086,7 @@ struct let constructors = List.map ~f:(fun { name; arguments; is_record; _ } -> - ( F.id (U.Concrete_ident_view.to_definition_name name), + ( F.id (RenderId.render name).name, Some (let field_indexes = List.map ~f:(fst3 >> index_of_field_concrete) arguments @@ -1105,7 +1096,7 @@ struct ( List.map ~f:(fun (field, ty, attrs) -> let fname : string = - U.Concrete_ident_view.to_definition_name field + (RenderId.render field).name in (F.id fname, None, [], pty e.span ty)) arguments, @@ -1128,7 +1119,7 @@ struct false, [ F.AST.TyconVariant - ( F.id @@ U.Concrete_ident_view.to_definition_name name, + ( F.id @@ (RenderId.render name).name, FStarBinder.of_generics e.span generics |> List.map ~f:FStarBinder.implicit_to_explicit |> List.map ~f:FStarBinder.to_binder, @@ -1144,8 +1135,8 @@ struct span = e.span; } in - match U.Concrete_ident_view.to_view macro with - | { crate = "hacspec_lib"; path = _; definition = name } -> ( + match RenderId.render macro with + | { path = "hacspec_lib" :: _; name } -> ( let unwrap r = match r with | Ok r -> r @@ -1207,12 +1198,12 @@ struct | _ -> unsupported_macro ()) | _ -> unsupported_macro ()) | Trait { name; generics; items } -> - let name_str = U.Concrete_ident_view.to_definition_name name in + let name_str = (RenderId.render name).name in let name_id = F.id @@ name_str in let fields = List.concat_map ~f:(fun i -> - let name = U.Concrete_ident_view.to_definition_name i.ti_ident in + let name = (RenderId.render i.ti_ident).name in let generics = FStarBinder.of_generics i.ti_span i.ti_generics in let bds = generics |> List.map ~f:FStarBinder.to_binder in let fields = @@ -1385,8 +1376,9 @@ struct in let add_pre n = n ^ "_pre" in let pre_name_str = - U.Concrete_ident_view.to_definition_name - (Concrete_ident.Create.map_last ~f:add_pre i.ti_ident) + (RenderId.render + (Concrete_ident.with_suffix `Pre i.ti_ident)) + .name in let pre = F.mk_app (F.term_of_lid [ pre_name_str ]) inputs @@ -1394,8 +1386,9 @@ struct let result = F.term_of_lid [ "result" ] in let add_post n = n ^ "_post" in let post_name_str = - U.Concrete_ident_view.to_definition_name - (Concrete_ident.Create.map_last ~f:add_post i.ti_ident) + (RenderId.render + (Concrete_ident.with_suffix `Post i.ti_ident)) + .name in let post = F.mk_app @@ -1470,7 +1463,7 @@ struct items; parent_bounds; } -> - let name = U.Concrete_ident_view.to_definition_name e.ident |> F.id in + let name = (RenderId.render e.ident).name |> F.id in let pat = F.pat @@ F.AST.PatVar (name, None, []) in let generics = FStarBinder.of_generics e.span generics in let pat = @@ -1486,7 +1479,7 @@ struct let fields = List.concat_map ~f:(fun { ii_span; ii_generics; ii_v; ii_ident } -> - let name = U.Concrete_ident_view.to_definition_name ii_ident in + let name = (RenderId.render ii_ident).name in match ii_v with | IIFn { body; params } -> @@ -1609,7 +1602,7 @@ let strings_of_item (bo : BackendOptions.t) m items (item : item) : let (module Print) = make m { - current_namespace = U.Concrete_ident_view.to_namespace item.ident; + current_namespace = (RenderId.render item.ident).path; interface_mode; items; line_width = bo.line_width; @@ -1651,7 +1644,7 @@ let string_of_items ~mod_name ~bundles (bo : BackendOptions.t) m items : |> Set.union_list (module Concrete_ident) |> Set.map (module String) - ~f:(fun i -> U.Concrete_ident_view.to_namespace i |> module_name) + ~f:(fun i -> (RenderId.render i).path |> module_name) |> Fn.flip Set.remove mod_name |> Set.to_list |> List.filter ~f:(fun m -> @@ -1755,11 +1748,11 @@ let fstar_headers (bo : BackendOptions.t) = (** Translate as F* (the "legacy" printer) *) let translate_as_fstar m (bo : BackendOptions.t) ~(bundles : AST.item list list) (items : AST.item list) : Types.file list = - let show_view Concrete_ident.{ crate; path; definition } = - crate :: (path @ [ definition ]) |> String.concat ~sep:"::" - in U.group_items_by_namespace items |> Map.to_alist + |> List.filter_map ~f:(fun (_, items) -> + let* first_item = List.hd items in + Some ((RenderId.render first_item.ident).path, items)) |> List.concat_map ~f:(fun (ns, items) -> let mod_name = module_name ns in let impl, intf = string_of_items ~mod_name ~bundles bo m items in diff --git a/engine/backends/proverif/proverif_backend.ml b/engine/backends/proverif/proverif_backend.ml index 8960e7df9..159aad007 100644 --- a/engine/backends/proverif/proverif_backend.ml +++ b/engine/backends/proverif/proverif_backend.ml @@ -98,7 +98,7 @@ module ProVerifNamePolicy = struct [@@@ocamlformat "disable"] - let index_field_transform index = Fn.id index + let anonymous_field_transform index = Fn.id index let reserved_words = Hash_set.of_list (module String) [ "among"; "axiom"; "channel"; "choice"; "clauses"; "const"; "def"; "diff"; "do"; "elimtrue"; "else"; "equation"; "equivalence"; "event"; "expand"; "fail"; "for"; "forall"; "foreach"; "free"; "fun"; "get"; "if"; "implementation"; "in"; "inj-event"; "insert"; "lemma"; "let"; "letfun"; "letproba"; "new"; "noninterf"; "noselect"; "not"; "nounif"; "or"; "otherwise"; "out"; "param"; "phase"; "pred"; "proba"; "process"; "proof"; "public vars"; "putbegin"; "query"; "reduc"; "restriction"; "secret"; "select"; "set"; "suchthat"; "sync"; "table"; "then"; "type"; "weaksecret"; "yield" @@ -111,7 +111,8 @@ module ProVerifNamePolicy = struct let struct_constructor_name_transform constructor_name = constructor_name ^ "_c" end -module U = Ast_utils.MakeWithNamePolicy (InputLanguage) (ProVerifNamePolicy) +module U = Ast_utils.Make (InputLanguage) +module RenderId = Concrete_ident.MakeRenderAPI (ProVerifNamePolicy) open AST module type OPTS = sig @@ -135,7 +136,7 @@ end module Make (Options : OPTS) : MAKE = struct module Print = struct module GenericPrint = - Deprecated_generic_printer.Make (InputLanguage) (U.Concrete_ident_view) + Deprecated_generic_printer.Make (InputLanguage) (RenderId) open Deprecated_generic_printer_base.Make (InputLanguage) open PPrint diff --git a/engine/bin/lib.ml b/engine/bin/lib.ml index d51009c20..5ffef0423 100644 --- a/engine/bin/lib.ml +++ b/engine/bin/lib.ml @@ -27,7 +27,7 @@ let import_thir_items (include_clauses : Types.inclusion_clause list) let imported_items = List.map ~f:(fun item -> - let ident = Concrete_ident.(of_def_id Kind.Value item.owner_id) in + let ident = Concrete_ident.(of_def_id ~value:true item.owner_id) in let most_precise_clause = (* Computes the include clause that apply to `item`, if any *) List.filter diff --git a/engine/lib/analyses/function_dependency.ml b/engine/lib/analyses/function_dependency.ml index 8a42ee869..0bef03ba6 100644 --- a/engine/lib/analyses/function_dependency.ml +++ b/engine/lib/analyses/function_dependency.ml @@ -10,16 +10,13 @@ module%inlined_contents Make (F : Features.T) = struct type analysis_data = concrete_ident list Map.M(String).t type id_order = int - module Uprint = - Ast_utils.MakeWithNamePolicy (F) (Concrete_ident.DefaultNamePolicy) - let analyse (items : A.item list) : analysis_data = let temp_list = List.concat_map ~f:U.functions_of_item items in List.fold_left ~init:(Map.empty (module String)) ~f:(fun y (name, body) -> Map.set y - ~key:(Uprint.Concrete_ident_view.to_definition_name name) + ~key:([%show: Concrete_ident.View.t] (Concrete_ident.to_view name)) ~data: (Set.to_list (U.Reducers.collect_concrete_idents#visit_expr () body))) diff --git a/engine/lib/analyses/mutable_variables.ml b/engine/lib/analyses/mutable_variables.ml index 63e8f5f18..50998ffd9 100644 --- a/engine/lib/analyses/mutable_variables.ml +++ b/engine/lib/analyses/mutable_variables.ml @@ -18,8 +18,7 @@ module%inlined_contents Make (F : Features.T) = struct (* external mut_vars and new variables (e.g. needs def / local) *) Map.M(String).t - module Uprint = - Ast_utils.MakeWithNamePolicy (F) (Concrete_ident.DefaultNamePolicy) + let id_to_string = Concrete_ident.to_view >> [%show: Concrete_ident.View.t] module LocalIdentOrData (Ty : sig type ty [@@deriving compare, sexp] @@ -130,8 +129,7 @@ module%inlined_contents Make (F : Features.T) = struct (module W) (List.map ~f:(fun x -> W.Identifier x) x), m#snd#zero )) - (Map.find data - (Uprint.Concrete_ident_view.to_definition_name cid)) + (Map.find data (id_to_string cid)) | _ -> super#visit_global_ident env x method! visit_concrete_ident (_env : W.t list Map.M(Local_ident).t) @@ -142,8 +140,7 @@ module%inlined_contents Make (F : Features.T) = struct (module W) (List.map ~f:(fun x -> W.Identifier x) x), m#snd#zero )) - (Map.find data - (Uprint.Concrete_ident_view.to_definition_name cid)) + (Map.find data (id_to_string cid)) end) #visit_expr env expr @@ -166,19 +163,14 @@ module%inlined_contents Make (F : Features.T) = struct List.fold_left ~init:(Map.empty (module String (* Concrete_ident *))) ~f:(fun y (x_name, x_items) -> - Map.set y - ~key:(Uprint.Concrete_ident_view.to_definition_name x_name) + Map.set y ~key:(id_to_string x_name) ~data: ( List.map ~f:(fst >> fst) x_items @ Option.value_map ~default:[] ~f: - (List.filter_map - ~f: - (Uprint.Concrete_ident_view.to_definition_name - >> Map.find y) + (List.filter_map ~f:(id_to_string >> Map.find y) >> List.concat_map ~f:fst) - (Map.find func_dep - (Uprint.Concrete_ident_view.to_definition_name x_name)), + (Map.find func_dep (id_to_string x_name)), x_items )) mut_var_list in diff --git a/engine/lib/ast.ml b/engine/lib/ast.ml index fbc798cb2..dbdb24aae 100644 --- a/engine/lib/ast.ml +++ b/engine/lib/ast.ml @@ -32,7 +32,7 @@ module Global_ident = struct include M module Map = Map.M (M) - let of_name kind n = `Concrete (Concrete_ident.of_name kind n) + let of_name ~value n = `Concrete (Concrete_ident.of_name ~value n) let eq_name name (x : t) : bool = match x with `Concrete x -> Concrete_ident.eq_name name x | _ -> false diff --git a/engine/lib/ast_builder.ml b/engine/lib/ast_builder.ml index 926fe262b..4a5b01096 100644 --- a/engine/lib/ast_builder.ml +++ b/engine/lib/ast_builder.ml @@ -27,7 +27,9 @@ module Make (F : Features.T) = struct let ty_cf ~(continue_type : ty) ~(break_type : ty) : ty = TApp { - ident = Global_ident.of_name Type Core__ops__control_flow__ControlFlow; + ident = + Global_ident.of_name ~value:false + Core__ops__control_flow__ControlFlow; args = [ GType break_type; GType continue_type ]; } @@ -72,14 +74,13 @@ module Make (F : Features.T) = struct PConstruct { constructor = - Global_ident.of_name - (Constructor { is_struct = false }) + Global_ident.of_name ~value:true Core__ops__control_flow__ControlFlow__Break; fields = [ { field = - Global_ident.of_name Field + Global_ident.of_name ~value:true Core__ops__control_flow__ControlFlow__Break__0; pat; }; @@ -96,14 +97,13 @@ module Make (F : Features.T) = struct PConstruct { constructor = - Global_ident.of_name - (Constructor { is_struct = false }) + Global_ident.of_name ~value:true Core__ops__control_flow__ControlFlow__Continue; fields = [ { field = - Global_ident.of_name Field + Global_ident.of_name ~value:true Core__ops__control_flow__ControlFlow__Continue__0; pat; }; @@ -133,8 +133,7 @@ module Make (F : Features.T) = struct let call_Constructor (constructor_name : Concrete_ident.name) (is_struct : bool) (args : expr list) span ret_typ = call_Constructor' - (`Concrete - (Concrete_ident.of_name (Constructor { is_struct }) constructor_name)) + (`Concrete (Concrete_ident.of_name ~value:true constructor_name)) is_struct args span ret_typ let expr'_Constructor_CF ~(span : span) ~(break_type : ty) diff --git a/engine/lib/ast_utils.ml b/engine/lib/ast_utils.ml index 01fe489dc..ef55bf45c 100644 --- a/engine/lib/ast_utils.ml +++ b/engine/lib/ast_utils.ml @@ -704,7 +704,8 @@ module Make (F : Features.T) = struct let never_typ : ty = let ident = - `Concrete (Concrete_ident.of_name Type Rust_primitives__hax__Never) + `Concrete + (Concrete_ident.of_name ~value:false Rust_primitives__hax__Never) in TApp { ident; args = [] } @@ -900,8 +901,7 @@ module Make (F : Features.T) = struct let call_Constructor (constructor_name : Concrete_ident.name) (is_struct : bool) (args : expr list) span ret_typ = call_Constructor' - (`Concrete - (Concrete_ident.of_name (Constructor { is_struct }) constructor_name)) + (`Concrete (Concrete_ident.of_name ~value:true constructor_name)) is_struct args span ret_typ let call' ?impl f ?(generic_args = []) ?(impl_generic_args = []) @@ -922,11 +922,10 @@ module Make (F : Features.T) = struct span; } - let call ?(kind : Concrete_ident.Kind.t = Value) ?(generic_args = []) - ?(impl_generic_args = []) ?impl (f_name : Concrete_ident.name) - (args : expr list) span ret_typ = + let call ?(generic_args = []) ?(impl_generic_args = []) ?impl + (f_name : Concrete_ident.name) (args : expr list) span ret_typ = call' ?impl ~generic_args ~impl_generic_args - (`Concrete (Concrete_ident.of_name kind f_name)) + (`Concrete (Concrete_ident.of_name ~value:true f_name)) args span ret_typ let make_closure (params : pat list) (body : expr) (span : span) : expr = @@ -951,7 +950,8 @@ module Make (F : Features.T) = struct let hax_failure_typ = let ident = - `Concrete (Concrete_ident.of_name Type Rust_primitives__hax__failure) + `Concrete + (Concrete_ident.of_name ~value:false Rust_primitives__hax__failure) in TApp { ident; args = [] } @@ -1270,40 +1270,14 @@ module Make (F : Features.T) = struct Option.value ~default:p (expect_deref_mut p) end - module StringList = struct - module U = struct - module T = struct - type t = string * string list - [@@deriving show, yojson, compare, sexp, eq, hash] - end - - include T - module C = Base.Comparator.Make (T) - include C - end - - include U - module Map = Map.M (U) - end - - let group_items_by_namespace_generic to_namespace (items : item list) : - item list StringList.Map.t = - let h = Hashtbl.create (module StringList) in + let group_items_by_namespace (items : item list) : + item list Concrete_ident.View.ModPath.Map.t = + let h = Hashtbl.create (module Concrete_ident.View.ModPath) in List.iter items ~f:(fun item -> - let ns = to_namespace item.ident in + let ns = (Concrete_ident.to_view item.ident).mod_path in let items = Hashtbl.find_or_add h ns ~default:(fun _ -> ref []) in items := !items @ [ item ]); Map.of_iteri_exn - (module StringList) + (module Concrete_ident.View.ModPath) ~iteri:(Hashtbl.map h ~f:( ! ) |> Hashtbl.iteri) end - -module MakeWithNamePolicy (F : Features.T) (NP : Concrete_ident.NAME_POLICY) = -struct - include Make (F) - open AST - module Concrete_ident_view = Concrete_ident.MakeViewAPI (NP) - - let group_items_by_namespace : item list -> item list StringList.Map.t = - group_items_by_namespace_generic Concrete_ident_view.to_namespace -end diff --git a/engine/lib/concrete_ident/concrete_ident.ml b/engine/lib/concrete_ident/concrete_ident.ml index ee48f35e0..43ddba63b 100644 --- a/engine/lib/concrete_ident/concrete_ident.ml +++ b/engine/lib/concrete_ident/concrete_ident.ml @@ -1,579 +1,667 @@ open! Prelude +module View = Concrete_ident_view -module Imported = struct - type def_id = { krate : string; path : path } - and path = disambiguated_def_path_item list +module Fresh_module : sig + (** This module provides a way of generating fresh modules paths. This can be + used to reorganize locally definitions; the main motivation for this is + recursive bundles, where we move definitions from multiple modules to + one fresh module. This is fine because we re-expose all the original + definitions. + *) - and disambiguated_def_path_item = { - data : def_path_item; - disambiguator : int; - } + type t [@@deriving show, yojson, hash, compare, sexp, hash, eq] - and def_path_item = - | CrateRoot - | Impl - | ForeignMod - | Use - | GlobalAsm - | Closure - | Ctor - | AnonConst - | AnonAdt - | OpaqueTy - | TypeNs of string - | ValueNs of string - | MacroNs of string - | LifetimeNs of string - [@@deriving show, yojson, compare, sexp, eq, hash] - - let of_def_path_item : Types.def_path_item -> def_path_item = function - | CrateRoot _ -> CrateRoot - | Impl -> Impl - | ForeignMod -> ForeignMod - | Use -> Use - | GlobalAsm -> GlobalAsm - | Closure -> Closure - | Ctor -> Ctor - | AnonConst -> AnonConst - | OpaqueTy -> OpaqueTy - | TypeNs s -> TypeNs s - | ValueNs s -> ValueNs s - | MacroNs s -> MacroNs s - | LifetimeNs s -> LifetimeNs s - | AnonAdt -> AnonAdt - - let of_disambiguated_def_path_item : - Types.disambiguated_def_path_item -> disambiguated_def_path_item = - fun Types.{ data; disambiguator } -> - { - data = of_def_path_item data; - disambiguator = MyInt64.to_int_exn disambiguator; - } - - let of_def_id - ({ contents = { value = { krate; path; _ }; _ } } : Types.def_id) = - { krate; path = List.map ~f:of_disambiguated_def_path_item path } - - let parent { krate; path; _ } = { krate; path = List.drop_last_exn path } - - let drop_ctor { krate; path; _ } = - { - krate; - path = - (match (List.drop_last path, List.last path) with - | Some path, Some { data = Ctor; _ } -> path - | _ -> path); - } - - let map_def_path_item_string ~(f : string -> string) : - def_path_item -> def_path_item = function - | TypeNs s -> TypeNs (f s) - | ValueNs s -> ValueNs (f s) - | MacroNs s -> MacroNs (f s) - | LifetimeNs s -> LifetimeNs (f s) - | other -> other - - let map_disambiguated_def_path_item_string ~(f : string -> string) - (x : disambiguated_def_path_item) : disambiguated_def_path_item = - { x with data = map_def_path_item_string ~f x.data } - - let map_path_strings ~(f : string -> string) (did : def_id) : def_id = - let f = map_disambiguated_def_path_item_string ~f in - { did with path = List.map ~f did.path } - - module AssociatedItem : sig - type t [@@deriving show, yojson, compare, sexp, eq, hash] - (** An identifier that is an associated item *) - - val from : def_id -> t option - (** If [id] is an associated item [ai], then [from id] evalues to [ai]. *) - - val impl : t -> def_id - (** Lookup the def_id of the [impl] block of an associated item. *) - - val path_decomposition : t -> path * disambiguated_def_path_item * path - (** [some::path::to::Impl#42::assoc::item] is decomposed into [(some::path::to, Impl#42, assoc::item)] *) - end = struct - let is_def_path_item_impl : def_path_item -> bool = function - | Impl -> true - | _ -> false - - (** Cuts a path in two if there is a [Impl] chunk. *) - let decompose_impl_path (path : path) : - (path * disambiguated_def_path_item * path) option = - let l, r = - List.split_while path ~f:(fun x -> is_def_path_item_impl x.data |> not) - in - let* impl_chunk = List.hd r in - let* r = List.tl r in - Some (l, impl_chunk, r) - - type t = { - impl_prefix : def_id; - (** the [def_id] of the impl in which the associated item - lives, but **without** the [Impl] chunk. Do not use this - directly. *) - impl_chunk : disambiguated_def_path_item; (** the [Impl] chunk *) - relative_path : path; - (** the (non-empty) relative path to the associated item *) - } - [@@deriving show, yojson, compare, sexp, eq, hash] - - let from (did : def_id) : t option = - let* impl_prefix, impl_chunk, relative_path = - decompose_impl_path did.path - in - let impl_prefix : def_id = { did with path = impl_prefix } in - if List.is_empty relative_path then None - else Some { impl_prefix; impl_chunk; relative_path } + val fresh : label:string -> Explicit_def_id.t list -> t + (** [fresh ~label hints] creates a fresh module out of the non-empty list of + explicit definition identifiers hints [hints] and out of a label [label]. - let impl { impl_prefix; impl_chunk; _ } = - { impl_prefix with path = impl_prefix.path @ [ impl_chunk ] } + The new module will have a unique path, close to [hints], and containing the + label [label]. + *) - let path_decomposition - { impl_prefix = { path = prefix; _ }; impl_chunk; relative_path } = - (prefix, impl_chunk, relative_path) - end -end + val register : fresh_module:t -> Explicit_def_id.t -> unit + (** [register ~fresh_module id] declares that [id] belongs to [fresh_module]. *) -module ImplInfos = struct - type t = Types.impl_infos - (** Contains the informations [Generics], [Trait] (if not an - inherent type), [Type] and [Bounds] for an [impl] block - [impl [Trait for] Type where Bounds {}] *) -end + val get_path_hints : t -> Explicit_def_id.t list + (** List path hints for a fresh module. *) -(** Stateful store that maps [def_id]s to implementation informations -(which trait is implemented? for which type? under which constraints?) *) -module ImplInfoStore : sig - val init : (Types.def_id * ImplInfos.t) list -> unit - - val find : Imported.def_id -> ImplInfos.t option - (** Given a [id] of type [def_id], [find id] will return [Some - impl_info] when [id] is an (non-inherent[1]) impl. [impl_info] - contains information about the trait being implemented and for - which type. - - [1]: https://doc.rust-lang.org/reference/items/implementations.html#inherent-implementations - *) - - val has_impl_prefix : - Imported.def_id -> (ImplInfos.t * Imported.path * Imported.path) option - (** If a [def_id] [did] points to an item that is an [impl] or a - child of an [impl], [has_impl_prefix did] returns [Some (infos, - before, after)]. [infos] is of type [ImplInfos.t] (cf its - documentation). [before] and [after] are the partial paths - before and after the [impl] in [did]'s path. Note that if - [after] is empty, that means [did] points to the [impl] - itself. - - TODO: drop that in favor of [Imported.AssociatedItem] API. - *) + val to_mod_path : t -> View.ModPath.t + (** Compute a module path for a fresh module. *) end = struct - let state : (Imported.def_id, ImplInfos.t) Hashtbl.t option ref = ref None - - module T = struct - type t = Imported.def_id [@@deriving show, yojson, compare, sexp, eq, hash] - end + open View + + type t = { id : int; hints : Explicit_def_id.t list; label : string } + [@@deriving show, yojson, hash, compare, sexp, hash, eq] + + let id_state = ref 0 + let map_state : _ Hashtbl.t = Hashtbl.create (module Int) + + let fresh ~label hints = + id_state := !id_state + 1; + assert (List.is_empty hints |> not); + { id = !id_state; hints; label } + + let register ~(fresh_module : t) (did : Explicit_def_id.t) = + let default = (Set.empty (module ModPath), None) in + let f (set, opt) = (Set.add set (View.of_def_id did).mod_path, opt) in + Hashtbl.update map_state fresh_module.id ~f:(Option.value ~default >> f) + + (** [compute_path_chunks fresh_module] returns [(mod_path, mod_name, + suffixes)]. [suffixes] are optional suffixes to add to [mod_name] so + that the resulting path is unique. *) + let compute_path_chunks (m : t) = + let mod_paths = List.map ~f:(fun d -> (of_def_id d).mod_path) m.hints in + let base = List.longest_prefix ~eq:DisambiguatedString.equal mod_paths in + assert (List.is_empty base |> not); + let module_names = + List.filter ~f:(List.length >> ( < ) (List.length base)) mod_paths + |> List.filter_map ~f:List.last + |> List.dedup_and_sort ~compare:[%compare: DisambiguatedString.t] + in + let hash = + List.dedup_and_sort ~compare:[%compare: Explicit_def_id.t] m.hints + |> [%hash: Explicit_def_id.t list] |> Int.to_string + |> DisambiguatedString.pure + in + let label = DisambiguatedString.pure m.label in + (base, label, module_names @ [ hash ]) - let init impl_infos = - state := - impl_infos - |> List.map ~f:(map_fst Imported.of_def_id) - |> Hashtbl.of_alist_multi (module T) - |> Hashtbl.map ~f:List.hd_exn |> Option.some - - let get_state () = - match !state with - | None -> failwith "ImplInfoStore was not initialized" - | Some state -> state - - let find k = Hashtbl.find (get_state ()) k - - let has_impl_prefix (did : Imported.def_id) = - match Imported.AssociatedItem.from did with - | None -> - let* before = List.tl did.path in - find did |> Option.map ~f:(fun infos -> (infos, before, [])) - | Some assoc_item -> ( - match Imported.AssociatedItem.impl assoc_item |> find with - | Some infos -> - let before, _, after = - Imported.AssociatedItem.path_decomposition assoc_item - in - Some (infos, before, after) - | None -> - (* TODO: This happens in actual code but should not, see #363 and #360. - Make this into an error when #363 is fixed. *) - Logs.warn (fun m -> - m - "concrete_ident: invariant error, no `impl_info` found for \ - identifier `%s`." - ([%show: Imported.def_id] did)); - None) + let all_paths () = + let rust_ones = + Explicit_def_id.State.list_all () + |> List.map ~f:(fun x -> (of_def_id x).mod_path) + in + let fresh_ones : ModPath.t list = + Hashtbl.data map_state |> List.filter_map ~f:snd + in + rust_ones @ fresh_ones + + let compute_path (m : t) = + let mod_path, mod_name, suffixes = compute_path_chunks m in + let existing_names = + all_paths () + |> List.filter_map ~f:last_init + |> List.filter ~f:(fst >> [%eq: ModPath.t] mod_path) + |> List.map ~f:snd + |> List.map ~f:(fun m -> m.DisambiguatedString.data) + |> Set.of_list (module String) + in + let mod_name = + List.mapi ~f:(fun n _ -> mod_name :: List.take suffixes n) suffixes + |> List.map ~f:(List.map ~f:(fun m -> m.DisambiguatedString.data)) + |> List.map ~f:(String.concat ~sep:"_") + |> List.find ~f:(Set.mem existing_names >> not) + |> Option.value_exn + ~message: + "Broken invariant: in fresh modules the suffix is supposed to be \ + crafted so that it is unique." + |> DisambiguatedString.pure + in + mod_path @ [ mod_name ] + + let to_mod_path m = + Hashtbl.update_and_return map_state m.id + ~f: + ( Option.value ~default:(Set.empty (module ModPath), None) + >> fun (paths, alloc) -> + ( paths, + alloc + |> Option.value_or_thunk ~default:(fun () -> compute_path m) + |> Option.some ) ) + |> snd |> Option.value_exn + + let get_path_hints { hints; _ } = hints end -module Kind = struct - type t = - | Type - | Value - | Lifetime - | Constructor of { is_struct : bool } - | Field - | Macro - | Trait - | Impl - | AssociatedItem of t - [@@deriving show, yojson, compare, sexp, eq, hash] - - let of_def_path_item : Imported.def_path_item -> t option = function - | TypeNs _ -> Some Type - | ValueNs _ -> Some Value - | LifetimeNs _ -> Some Lifetime - | _ -> None +type reserved_suffix = [ `Cast | `Pre | `Post ] +[@@deriving show, yojson, hash, compare, sexp, hash, eq] +(** A concrete identifier can have a reserved suffix: this is useful to derive + new identifiers from existing identifiers. *) + +module T = struct + type t = { + def_id : Explicit_def_id.t; + moved : Fresh_module.t option; + suffix : reserved_suffix option; + } + [@@deriving show, yojson, hash, compare, sexp, hash, eq] end -module View = struct - module T = struct - type view = { crate : string; path : string list; definition : string } - end +include T +include Comparator.Make (T) - include T +let to_debug_string = T.show - module Utils = struct - let string_of_def_path_item : Imported.def_path_item -> string option = - function - | TypeNs s | ValueNs s | MacroNs s | LifetimeNs s -> Some s - | Impl -> Some "impl" - | AnonConst -> Some "anon_const" - | _ -> None +let fresh_module ~label = + List.concat_map ~f:(fun { def_id; moved; _ } -> + def_id + :: (Option.to_list moved |> List.concat_map ~f:Fresh_module.get_path_hints)) + >> Fresh_module.fresh ~label - let string_of_disambiguated_def_path_item - (x : Imported.disambiguated_def_path_item) : string option = - let n = x.disambiguator in - string_of_def_path_item x.data - |> Option.map ~f:(fun base -> - match n with - | 0 -> ( - match String.rsplit2 ~on:'_' base with - | Some (_, "") -> base ^ "_" - | Some (_, r) when Option.is_some @@ Stdlib.int_of_string_opt r - -> - base ^ "_" (* potentially conflicting name, adding a `_` *) - | _ -> base) - | _ -> base ^ "_" ^ Int.to_string n) - end +module Cache = struct + let state = Hash_set.create (module T) + let cached = Fn.id &&& Hash_set.add state >> fst +end - open Utils +let make (def_id : Explicit_def_id.t) (moved : Fresh_module.t option) + (suffix : reserved_suffix option) = + { def_id; moved; suffix } + +let of_def_id ?(suffix : reserved_suffix option = None) ~(value : bool) + (def_id : Types.def_id) = + let constructor = + (* A DefId is a constructor when it's a value and points to a variant, a union or a struct. *) + value + && [%matches? (Variant | Union | Struct : Types.def_kind)] + def_id.contents.value.kind + in + make (Explicit_def_id.of_def_id_exn ~constructor def_id) None suffix + |> Cache.cached - let simple_ty_to_string ~(namespace : Imported.def_id) : - Types.node_for__ty_kind -> string option = - let escape = - let re = Re.Pcre.regexp "_((?:e_)*)of_" in - let f group = "_e_" ^ Re.Group.get group 1 ^ "of_" in - Re.replace ~all:true re ~f - in - let adt def_id = - let* () = - [%equal: Imported.def_id] - (Imported.(of_def_id >> parent) def_id) - namespace - |> some_if_true - in - let* last = List.last def_id.contents.value.path in - let* () = some_if_true Int64.(last.disambiguator = zero) in - last.data |> Imported.of_def_path_item |> string_of_def_path_item - |> Option.map ~f:escape - in - let arity0 (ty : Types.node_for__ty_kind) = - match ty.Types.value with - | Bool -> Some "bool" - | Char -> Some "char" - | Str -> Some "str" - | Never -> Some "never" - | Int Isize -> Some "isize" - | Int I8 -> Some "i8" - | Int I16 -> Some "i16" - | Int I32 -> Some "i32" - | Int I64 -> Some "i64" - | Int I128 -> Some "i128" - | Uint Usize -> Some "usize" - | Uint U8 -> Some "u8" - | Uint U16 -> Some "u16" - | Uint U32 -> Some "u32" - | Uint U64 -> Some "u64" - | Uint U128 -> Some "u128" - | Float F32 -> Some "f32" - | Float F64 -> Some "f64" - | Tuple [] -> Some "unit" - | Adt { def_id; generic_args = []; _ } -> - Option.map ~f:escape (adt def_id) - | _ -> None - in - let apply left right = left ^ "_of_" ^ right in - let rec arity1 (ty : Types.node_for__ty_kind) = - match ty.value with - | Slice sub -> arity1 sub |> Option.map ~f:(apply "slice") - | Ref (_, sub, _) -> arity1 sub |> Option.map ~f:(apply "ref") - | Adt { def_id; generic_args = [ Type arg ]; _ } -> - let* adt = adt def_id in - let* arg = arity1 arg in - Some (apply adt arg) - | Tuple l -> - let* l = List.map ~f:arity0 l |> Option.all in - Some ("tuple_" ^ String.concat ~sep:"_" l) - | _ -> arity0 ty - in - arity1 - - let rec to_view (def_id : Imported.def_id) : view = - let impl_infos = ImplInfoStore.has_impl_prefix def_id in - let def_id = - match impl_infos with - (* inherent impl: we don't want the [impl] keyword to appear *) - | Some ({ trait_ref = Some _; _ }, lpath, rpath) - when not (List.is_empty rpath) -> - (* this basically amounts exactly to dropping the [impl] chunk *) - Imported.{ krate = def_id.krate; path = lpath @ rpath } - | _ -> def_id - in - let path, definition = - List.filter_map ~f:string_of_disambiguated_def_path_item def_id.path - |> last_init |> Option.value_exn - in - let path = - List.filter - ~f:(String.is_prefix ~prefix:"hax__autogenerated_refinement__" >> not) - path - in - let sep = "__" in - let subst = String.substr_replace_all ~pattern:sep ~with_:(sep ^ "_") in - let fake_path, real_path = - (* Detects paths of nested items *) - List.rev def_id.path |> List.tl_exn - |> List.split_while ~f:(fun (x : Imported.disambiguated_def_path_item) -> - [%matches? Imported.ValueNs _ | Imported.Impl] x.data) - |> List.rev *** List.rev - in - let subst_dpi = - string_of_disambiguated_def_path_item >> Option.map ~f:subst - in - let definition = subst definition in - let fake_path, definition = - let fake_path' = List.filter_map ~f:subst_dpi fake_path in - match impl_infos with - | Some - ( { trait_ref = None; generics = { params = []; _ }; typ; _ }, - before, - _ ) - when [%matches? [ Imported.{ data = Impl; _ } ]] fake_path -> - let namespace = Imported.{ krate = def_id.krate; path = before } in - simple_ty_to_string ~namespace typ - |> Option.map ~f:(fun typ -> ([ "impl"; typ ], definition)) - |> Option.value ~default:(fake_path', definition) - | Some - ( { - trait_ref = Some { def_id = trait; generic_args = [ _self ] }; - generics = { params = []; _ }; - typ; - _; - }, - before, - [] ) -> - let namespace = Imported.{ krate = def_id.krate; path = before } in - (let* () = - some_if_true - @@ [%equal: Imported.def_id] - (Imported.(of_def_id >> parent) trait) - namespace - in - let* typ = simple_ty_to_string ~namespace typ in - let* trait = List.last trait.contents.value.path in - let* trait = - Imported.of_def_path_item trait.data |> string_of_def_path_item - in - let sep = "_for_" in - let trait = - let re = Re.Pcre.regexp "_((?:e_)*)for_" in - let f group = "_e_" ^ Re.Group.get group 1 ^ "for_" in - Re.replace ~all:true re ~f trait - in - Some ("impl_" ^ trait ^ sep ^ typ)) - |> Option.value ~default:definition - |> tup2 fake_path' - | _ -> (fake_path', definition) - in - let real_path = List.filter_map ~f:subst_dpi real_path in - if List.is_empty fake_path then { crate = def_id.krate; path; definition } - else - let definition = String.concat ~sep (fake_path @ [ definition ]) in - { crate = def_id.krate; path = real_path; definition } +let move_to_fresh_module (fresh_module : Fresh_module.t) (i : t) = + Fresh_module.register ~fresh_module i.def_id; + Cache.cached { i with moved = Some fresh_module } - and to_definition_name x = (to_view x).definition -end +let with_suffix (suffix : reserved_suffix) (i : t) : t = + { i with suffix = Some suffix } -module T = struct - type t = { def_id : Imported.def_id; kind : Kind.t } - [@@deriving show, yojson, sexp] +module type VIEW_RENDERER = sig + val render_module : View.DisambiguatedString.t -> string - (* [kind] is really a metadata, it is not relevant, `def_id`s are unique *) - let equal x y = [%equal: Imported.def_id] x.def_id y.def_id - let compare x y = [%compare: Imported.def_id] x.def_id y.def_id - let of_def_id kind def_id = { def_id = Imported.of_def_id def_id; kind } - let hash x = [%hash: Imported.def_id] x.def_id - let hash_fold_t s x = Imported.hash_fold_def_id s x.def_id + val render_name : + namespace:View.ModPath.t -> View.RelPath.Chunk.t list -> string - type name = Concrete_ident_generated.t - [@@deriving show, yojson, compare, sexp, eq, hash] + val finalize : Concrete_ident_render_sig.rendered -> string +end - let of_name k = Concrete_ident_generated.def_id_of >> of_def_id k +let to_view (ident : t) : Concrete_ident_view.t = + let Concrete_ident_view.{ mod_path; rel_path } = + View.of_def_id ident.def_id + in + let mod_path = + Option.map ~f:Fresh_module.to_mod_path ident.moved + |> Option.value ~default:mod_path + in + { mod_path; rel_path } - let eq_name name id = - let of_name = - Concrete_ident_generated.def_id_of name |> Imported.of_def_id +(** Stateful store that maps [def_id]s to implementation informations +(which trait is implemented? for which type? under which constraints?) *) +module ImplInfoStore = struct + include Explicit_def_id.ImplInfoStore + + let lookup_raw (impl : t) : Types.impl_infos option = lookup_raw impl.def_id +end + +module MakeToString (R : VIEW_RENDERER) = struct + open Concrete_ident_render_sig + + (** For each module namespace, we store three different pieces of data: + - a map from relative paths (i.e. the non-module part of a path) to full + identifiers + - an set of rendered names in this namespace + - a memoization map from full identifiers to rendered names + + If an identifier was already rendered, we just use this already rendered + name. + + Otherwise, when we print a name under a fresh module, we take a look at + the first map: if there is already an identifier in the fresh module with + the exact same relative path, then we have a collision, and we need to + generate a fresh name. + + To generate a fresh name, we use the set of rendered names. + *) + let per_module : + ( string list, + (View.RelPath.t, t) Hashtbl.t + * string Hash_set.t + * (t, string) Hashtbl.t ) + Hashtbl.t = + Hashtbl.create + (module struct + type t = string list [@@deriving hash, compare, sexp, eq] + end) + + let render (i : t) : rendered = + let Concrete_ident_view.{ mod_path; rel_path } = to_view i in + let path = List.map ~f:R.render_module mod_path in + (* Retrieve the various maps. *) + let rel_path_map, name_set, memo = + Hashtbl.find_or_add per_module + ~default:(fun _ -> + ( Hashtbl.create (module View.RelPath), + Hash_set.create (module String), + Hashtbl.create (module T) )) + path + in + (* If we rendered [i] already in the past, just use that. *) + let name = + match Hashtbl.find memo i with + | Some name -> name + | None -> + let name = R.render_name ~namespace:mod_path rel_path in + let name = + match i.suffix with + | Some suffix -> ( + name ^ "_" + ^ + match suffix with + | `Pre -> "pre" + | `Post -> "post" + | `Cast -> "cast_to_repr") + | _ -> name + in + let moved_into_fresh_ns = Option.is_some i.moved in + let name = + if moved_into_fresh_ns then + let escape_sep = + let re = Re.Pcre.regexp "__(e*)from__" in + let f group = "__e" ^ Re.Group.get group 1 ^ "from__" in + Re.replace ~all:true re ~f + in + escape_sep name + else name + in + let name = + match Hashtbl.find rel_path_map rel_path with + | Some _ when moved_into_fresh_ns -> + let path : View.ModPath.t = + (View.of_def_id i.def_id).mod_path + in + let path = List.map ~f:R.render_module path in + (* Generates the list of all prefixes of reversed `path` *) + List.folding_map ~init:[] (List.rev path) ~f:(fun acc chunk -> + let acc = chunk :: acc in + (acc, acc)) + (* We want to try small prefixes first *) + |> List.map ~f:List.rev + (* We generate a fake path with module ancestors *) + |> List.map ~f:(fun path -> + name ^ "__from__" + ^ String.concat ~sep:"__" + path (* This might shadow, we should escape *)) + (* Find the shortest name that doesn't exist already *) + |> List.find ~f:(Hash_set.mem name_set >> not) + |> Option.value_exn + | _ -> name + in + (* Update the maps and hashtables *) + let _ = Hashtbl.add rel_path_map ~key:rel_path ~data:i in + let _ = Hash_set.add name_set name in + let _ = Hashtbl.add memo ~key:i ~data:name in + name in - [%equal: Imported.def_id] of_name id.def_id + { path; name } + + let show (i : t) : string = + let { path; name } = render i in + R.finalize { path; name } end -include T -include View.T -include (val Comparator.make ~compare ~sexp_of_t) +module RenderSig = Concrete_ident_render_sig.Make (T) +include RenderSig -include Concrete_ident_sig.Make (struct - type t_ = t - type view_ = view -end) +module type NAME_POLICY = Concrete_ident_render_sig.NAME_POLICY -module MakeViewAPI (NP : NAME_POLICY) : VIEW_API = struct - type t = T.t +module MakeRenderAPI (NP : NAME_POLICY) : RENDER_API = struct + open Concrete_ident_render_sig - let pp fmt = show >> Stdlib.Format.pp_print_string fmt let is_reserved_word : string -> bool = Hash_set.mem NP.reserved_words - let rename_definition (_path : string list) (name : string) (kind : Kind.t) - type_name = - (* let path, name = *) - (* match kind with *) - (* | Constructor { is_struct = false } -> *) - (* let path, type_name = (List.drop_last_exn path, List.last_exn path) in *) - (* (path, type_name ^ "_" ^ name) *) - (* | _ -> (path, name) *) - (* in *) - let prefixes = [ "t"; "C"; "v"; "f"; "i"; "discriminant" ] in - let escape s = - match String.lsplit2 ~on:'_' s with - | Some (prefix, _) when List.mem ~equal:String.equal prefixes prefix -> - String.prefix prefix 1 ^ s + module R : VIEW_RENDERER = struct + let disambiguator_escape s = + match split_str ~on:"_" s |> List.rev with + | hd :: _ :: _ when Int.of_string_opt hd |> Option.is_some -> s ^ "_" | _ -> s - in - match kind with - | Type | Trait -> "t_" ^ name - | Value | Impl -> - if start_uppercase name || is_reserved_word name then "v_" ^ name - else escape name - | Constructor { is_struct } -> - let name = - if start_lowercase name || is_reserved_word name then "C_" ^ name - else escape name + + let render_disambiguated View.DisambiguatedString.{ disambiguator; data } = + if Int64.equal Int64.zero disambiguator then disambiguator_escape data + else data ^ "_" ^ Int64.to_string disambiguator + + let render_module = render_disambiguated + + module NameAst = struct + module Separator = struct + let separator = "__" + let concat x y = x ^ separator ^ y + + let escape = + let re = Re.Pcre.regexp "_(e*)_" in + let f group = "_e" ^ Re.Group.get group 1 ^ "_" in + Re.replace ~all:true re ~f + end + + module Prefixes : sig + type t = private string [@@deriving eq, show] + + val allowed : t list + (** List of allowed reserved prefixes. *) + + val mk : string -> t + (** Creates a prefix, if it is valid. *) + + val escape : string -> string + (** Escapes reserved prefixes in a string *) + end = struct + type t = string [@@deriving eq, show] + + let allowed = + [ + "impl"; + "anon_const"; + "foreign"; + "use"; + "opaque"; + "t"; + "C"; + "v"; + "f"; + "i"; + "discriminant"; + ] + + let mem = List.mem ~equal:[%eq: string] allowed + + let mk s = + if mem s then s + else + failwith ("broken invariant: [" ^ s ^ "] is not an allowed prefix") + + let escape_char = "e" + + let () = + assert ( + (* Make sure there is no prefix `Cs` such that `C ^ "s"` is a prefix as well. *) + List.for_all allowed ~f:(fun s -> not (mem (first_letter s ^ s)))) + + let () = assert (mem "e" |> not) + + let rec escape (s : string) : string = + match String.lsplit2 ~on:'_' s with + | Some ("", rest) -> "e_" ^ escape rest + | Some (prefix, rest) + when List.mem ~equal:[%equal: string] allowed prefix -> + first_letter prefix ^ prefix ^ "_" ^ escape rest + | _ -> s + end + + type policy = { + prefix : Prefixes.t; + disable_when : [ `SameCase ] list; + mode : [ `Global | `Local | `Both ]; + } + [@@deriving eq, show] + + type t = + | Concat of (t * t) (** Concatenate two names *) + | Policy of (policy * t) + | TrustedString of string (** A string that is already escaped *) + | UnsafeString of string (** A string that needs escaping *) + | Empty + [@@deriving eq, show] + + let rec global_policy ast : _ = + let filter = + Option.filter ~f:(fun p -> [%matches? `Global | `Both] p.mode) in - if is_struct then NP.struct_constructor_name_transform name - else - let enum_name = type_name |> Option.value_exn in - NP.enum_constructor_name_transform ~enum_name name - | Field | AssociatedItem _ -> - let struct_name = type_name |> Option.value_exn in - NP.field_name_transform ~struct_name - (match Stdlib.int_of_string_opt name with - | Some _ -> NP.index_field_transform name - | _ -> "f_" ^ name) - | Lifetime | Macro -> escape name - - let rec to_view' ({ def_id; kind } : t) : view = - let def_id = Imported.drop_ctor def_id in - let View.{ crate; path; definition } = View.to_view def_id in - let type_name = - try - { def_id = Imported.parent def_id; kind = Type } - |> to_definition_name - |> String.chop_prefix_exn ~prefix:"t_" - |> Option.some - with _ -> None - in - let path, definition = - match kind with - | Constructor { is_struct = false } -> - ( List.drop_last_exn path, - Option.value_exn type_name ^ "_" ^ definition ) - | Field when List.last path |> [%equal: string option] type_name -> - (List.drop_last_exn path, definition) - | AssociatedItem _ -> (List.drop_last_exn path, definition) - | _ -> (path, definition) - in - let definition = rename_definition path definition kind type_name in - View.{ crate; path; definition } - - and to_view ({ def_id; kind } : t) : view = - match List.last def_id.path with - (* Here, we assume an `AnonConst` is a discriminant *) - | Some { data = Imported.AnonConst; _ } -> - let View.{ crate; path; definition } = - to_view' - { - def_id = Imported.parent def_id; - kind = Constructor { is_struct = false }; - } + let ( <|> ) v f = match v with Some v -> Some v | None -> f () in + match ast with + | Policy (policy, contents) -> + global_policy contents |> filter <|> fun _ -> + policy |> Option.some |> filter + | Concat (l, r) -> + global_policy r |> filter <|> fun _ -> global_policy l |> filter + | _ -> None + + let escape_unsafe_string = Prefixes.escape >> Separator.escape + + let apply_policy (leftmost : bool) (policy : policy) (escaped : string) = + let prefix = (policy.prefix :> string) in + let disable = + List.exists policy.disable_when ~f:(function `SameCase -> + let first_upper = first_letter >> is_uppercase in + Bool.equal (first_upper prefix) (first_upper escaped)) + in + if (not disable) || (leftmost && is_reserved_word escaped) then + prefix ^ "_" ^ escaped + else escaped + + let rec norm' = function + | Concat (Empty, x) | Concat (x, Empty) -> x + | Policy (_, Empty) -> Empty + | Policy (p, x) -> Policy (p, norm' x) + | Concat (x, y) -> Concat (norm' x, norm' y) + | x -> x + + let rec norm x = + let x' = norm' x in + if [%eq: t] x x' then x else norm x' + + let concat_list = + List.fold ~f:(fun l r -> Concat (l, r)) ~init:Empty >> norm + + let rec render' leftmost ast = + match ast with + | Concat (a, b) -> + Separator.concat (render' leftmost a) (render' false b) + | Policy (policy, a) when [%matches? `Global] policy.mode -> + render' leftmost a + | Policy (policy, a) -> + render' leftmost a |> apply_policy leftmost policy + | TrustedString s -> s + | UnsafeString s -> escape_unsafe_string s + | Empty -> "" + + let render ast = + let policy = global_policy ast in + let policy = + Option.map ~f:(apply_policy true) policy + |> Option.value ~default:Fn.id in - View.{ crate; path; definition = "discriminant_" ^ definition } - | _ -> to_view' { def_id; kind } + let rendered = norm ast |> render' true |> policy in + if is_reserved_word rendered then rendered ^ "_escape_reserved_word" + else rendered + end + + (** [pretty_impl_name ~namespace impl_infos] computes a pretty impl name given impl informations and a namespace. + A pretty name can be computed when: + - (1) the impl, (2) the type and (3) the trait implemented all live in the same namespace + - the impl block has no generics + - the type implemented is simple enough to be represented as a string (see module {!Thir_simple_types}) + *) + let pretty_impl_name ~namespace (impl_infos : Types.impl_infos) = + let* ty = Thir_simple_types.to_string ~namespace impl_infos.typ in + let*? _no_generics = List.is_empty impl_infos.generics.params in + match impl_infos.trait_ref with + | None -> Some ty + | Some { def_id = trait; generic_args = [ _self ] } -> + let* trait = Explicit_def_id.of_def_id trait in + let trait = View.of_def_id trait in + let*? _same_ns = [%eq: View.ModPath.t] namespace trait.mod_path in + let* trait = + match trait.rel_path with + | [ `Trait (n, _) ] when Int64.equal Int64.zero n.disambiguator -> + Some n.data + | _ -> None + in + let trait = + let re = Re.Pcre.regexp "_((?:e_)*)for_" in + let f group = "_e_" ^ Re.Group.get group 1 ^ "for_" in + Re.replace ~all:true re ~f trait + in + Some (trait ^ "_for_" ^ ty) + | _ -> None - and to_definition_name (x : t) : string = (to_view x).definition + (** Produces a name for an impl block, only if it is necessary (e.g. the disambiguator is non-null) *) + let impl_name ~namespace ?(always = false) disambiguator + (impl_infos : Types.impl_infos option) = + let pretty = impl_infos |> Option.bind ~f:(pretty_impl_name ~namespace) in + let*? _ = always || Int64.equal Int64.zero disambiguator |> not in + match pretty with + | Some pretty -> Some pretty + | None -> + if Int64.equal Int64.zero disambiguator then None + else Some (Int64.to_string disambiguator) + + (** Renders one chunk *) + let rec render_chunk ~namespace (chunk : View.RelPath.Chunk.t) : NameAst.t = + let prefix ?(global = false) ?(disable_when = []) s contents = + NameAst.Policy + ( { + prefix = NameAst.Prefixes.mk s; + mode = (if global then `Both else `Local); + disable_when; + }, + contents ) + in + let prefix_d s d = prefix s (NameAst.UnsafeString (Int64.to_string d)) in + let dstr s = NameAst.UnsafeString (render_disambiguated s) in + let _render_chunk = render_chunk ~namespace in + match chunk with + | `AnonConst d -> prefix_d "anon_const" d + | `Use d -> prefix_d "use" d + | `Foreign d -> prefix_d "foreign" d + | `GlobalAsm d -> prefix_d "global_asm" d + | `Opaque d -> prefix_d "opaque" d + (* The name of a trait impl *) + | `Impl (d, _, impl_infos) -> ( + match impl_name ~namespace d impl_infos with + | Some name -> prefix "impl" (UnsafeString name) + | None -> TrustedString "impl") + (* Print the name of an associated item in a inherent impl *) + | `AssociatedItem + ((`Type n | `Const n | `Fn n), `Impl (d, `Inherent, impl_infos)) -> + let impl = + match impl_name ~always:true ~namespace d impl_infos with + | Some name -> prefix "impl" (UnsafeString name) + | None -> TrustedString "impl" + in + Concat (impl, dstr n) + (* Print the name of an associated item in a trait impl *) + | `AssociatedItem + ((`Type n | `Const n | `Fn n), (`Trait _ | `Impl (_, `Trait, _))) -> + prefix "f" (dstr n) + (* The constructor of a struct *) + | `Constructor (cons, parent) -> + let cons = render_disambiguated cons in + let include_type, type_name = + match parent with + | `Struct n -> (NP.prefix_struct_constructors_with_type, n) + | `Enum n -> (NP.prefix_enum_constructors_with_type, n) + | `Union n -> (NP.prefix_union_constructors_with_type, n) + in + let cons = + if include_type then render_disambiguated type_name ^ "_" ^ cons + else cons + in + prefix ~global:true ~disable_when:[ `SameCase ] "C" + (UnsafeString cons) + (* Anonymous fields *) + | `Field ({ data; disambiguator }, _) + when Option.is_some (Int.of_string_opt data) + && Int64.equal disambiguator Int64.zero -> + UnsafeString (NP.anonymous_field_transform data) + (* Named fields *) + | `Field (n, _) -> prefix "f" (dstr n) + (* Anything function-like *) + | `Macro n | `Static n | `Fn n | `Const n -> + prefix "v" ~disable_when:[ `SameCase ] (dstr n) + (* Anything type-like *) + | `ExternCrate n + | `Trait (n, _) + | `ForeignTy n + | `TraitAlias n + | `Mod n + | `Struct n + | `Union n + | `Enum n -> + prefix "t" (dstr n) + + let render_name ~namespace (rel_path : View.RelPath.t) = + let rel_path = + List.map ~f:(render_chunk ~namespace) rel_path |> NameAst.concat_list + in + NameAst.render rel_path - let to_crate_name (x : t) : string = (to_view x).crate + let finalize { path; name } = + let path = List.map ~f:(map_first_letter String.uppercase) path in + String.concat ~sep:"." + (path @ if String.is_empty name then [] else [ name ]) + end - let to_namespace x = - let View.{ crate; path; _ } = to_view x in - (crate, path) + include MakeToString (R) - let show x = - to_view x - |> (fun View.{ crate; path; definition } -> - crate :: (path @ [ definition ])) + let pp fmt = T.show >> Stdlib.Format.pp_print_string fmt + + let show id = + let { path; name } = render id in + (path @ if String.is_empty name then [] else [ name ]) |> String.concat ~sep:"::" - let local_ident (li : Local_ident.t) = + let local_ident (li : Local_ident.t) : string = if Local_ident.is_final li then li.name else - to_definition_name - { - def_id = - { - krate = "dummy_for_local_name"; - path = [ { data = ValueNs li.name; disambiguator = 0 } ]; - }; - kind = Value; - } + R.render_name ~namespace:[] + [ + `Fn + View.DisambiguatedString. + { disambiguator = Int64.zero; data = li.name }; + ] end -let to_debug_string = T.show +type name = Concrete_ident_generated.t +[@@deriving show, yojson, compare, sexp, eq, hash] + +let of_name ~value = Concrete_ident_generated.def_id_of >> of_def_id ~value -let map_path_strings ~(f : string -> string) (cid : t) : t = - { cid with def_id = Imported.map_path_strings ~f cid.def_id } +let eq_name name id = + let of_name = Concrete_ident_generated.def_id_of name in + [%equal: Types.def_id_contents] of_name.contents.value + (Explicit_def_id.to_def_id id.def_id) -module DefaultNamePolicy = struct +module DefaultNamePolicy : NAME_POLICY = struct let reserved_words = Hash_set.create (module String) - let index_field_transform = Fn.id - let field_name_transform ~struct_name:_ = Fn.id - let enum_constructor_name_transform ~enum_name:_ = Fn.id - let struct_constructor_name_transform = Fn.id + let anonymous_field_transform = Fn.id + let prefix_struct_constructors_with_type = false + let prefix_enum_constructors_with_type = true + let prefix_union_constructors_with_type = false end +module DefaultViewAPI = MakeRenderAPI (DefaultNamePolicy) + +let map_path_strings ~(f : string -> string) (did : t) : t = + let constructor = did.def_id |> Explicit_def_id.is_constructor in + let did : Types.def_id_contents = did.def_id |> Explicit_def_id.to_def_id in + let path = + did.path + |> List.map ~f:(fun (chunk : Types.disambiguated_def_path_item) -> + let data = + match chunk.data with + | TypeNs s -> Types.TypeNs (f s) + | ValueNs s -> ValueNs (f s) + | MacroNs s -> MacroNs (f s) + | LifetimeNs s -> LifetimeNs (f s) + | data -> data + in + { chunk with data }) + in + let did = { did with path } in + let def_id = + Explicit_def_id.of_def_id_exn ~constructor + { contents = { value = did; id = Base.Int64.zero } } + in + { def_id; moved = None; suffix = None } + let matches_namespace (ns : Types.namespace) (did : t) : bool = - let did = did.def_id in + let did = Explicit_def_id.to_def_id did.def_id in let path : string option list = - Some did.krate - :: (did.path - |> List.map ~f:(fun (x : Imported.disambiguated_def_path_item) -> - View.Utils.string_of_def_path_item x.data)) + [ Some did.krate ] + @ List.map + ~f:(fun (chunk : Types.disambiguated_def_path_item) -> + match chunk.data with + | TypeNs s | ValueNs s | MacroNs s | LifetimeNs s -> Some s + | _ -> None) + did.path in let rec aux (pattern : Types.namespace_chunk list) (path : string option list) = @@ -588,84 +676,3 @@ let matches_namespace (ns : Types.namespace) (did : t) : bool = | _ -> false in aux ns.chunks path - -module Create = struct - let parent (id : t) : t = { id with def_id = Imported.parent id.def_id } - - let fresh_module ~from = - let len x = List.length x.def_id.path in - let compare x y = len x - len y in - let id = List.min_elt ~compare from |> Option.value_exn in - { - kind = Kind.Value; - def_id = - { - id.def_id with - path = - id.def_id.path - @ [ - { - data = TypeNs "cyclic_bundle"; - disambiguator = [%hash: t list] from; - }; - ]; - }; - } - - let move_under ~new_parent old = - let new_parent = new_parent.def_id in - { - kind = old.kind; - def_id = - { - new_parent with - path = new_parent.path @ [ List.last_exn old.def_id.path ]; - }; - } - - let map_last ~f old = - let last = - List.last_exn old.def_id.path - |> Imported.map_disambiguated_def_path_item_string ~f - in - let path = List.drop_last_exn old.def_id.path @ [ last ] in - { old with def_id = { old.def_id with path } } - - let replace_last old chunk = - { - old with - def_id = - { - old.def_id with - path = - List.drop_last_exn old.def_id.path - @ [ { data = Imported.ValueNs chunk; disambiguator = 0 } ]; - }; - } - - let constructor name = - let path = name.def_id.path @ [ { data = Ctor; disambiguator = 0 } ] in - { name with def_id = { name.def_id with path } } - - let add_disambiguator name disambiguator = - let path = name.def_id.path in - if List.is_empty path then name - else - (* The following two `exn` function calls cannot fail as the path is not empty. *) - let last = List.last_exn path in - let path = - List.drop_last_exn path @ [ { data = last.data; disambiguator } ] - in - { name with def_id = { name.def_id with path } } -end - -let lookup_raw_impl_info (impl : t) : Types.impl_infos option = - ImplInfoStore.find impl.def_id - -let parent_impl (id : t) : t option = - let* assoc_item = Imported.AssociatedItem.from id.def_id in - let def_id = Imported.AssociatedItem.impl assoc_item in - Some { def_id; kind = Kind.Impl } - -module DefaultViewAPI = MakeViewAPI (DefaultNamePolicy) -include DefaultViewAPI diff --git a/engine/lib/concrete_ident/concrete_ident.mli b/engine/lib/concrete_ident/concrete_ident.mli index 168fc3e3f..21c587206 100644 --- a/engine/lib/concrete_ident/concrete_ident.mli +++ b/engine/lib/concrete_ident/concrete_ident.mli @@ -1,84 +1,103 @@ -type t [@@deriving show, yojson, compare, sexp, eq, hash] +(** This module provides the global concrete identifiers. *) + +module Fresh_module : sig + type t [@@deriving show, yojson, hash, compare, sexp, hash, eq] + (** A type representing a fresh module. Below, we define two functions: + - [fresh] creates a new fresh module + - [move_to_fresh_module] creates a new and always fresh identifier by + "moving" an existing identifier under the given fresh module + *) +end -type name = Concrete_ident_generated.t -[@@deriving show, yojson, compare, sexp, eq, hash] +module View : module type of Concrete_ident_view -module ImplInfoStore : sig - val init : (Types.def_id * Types.impl_infos) list -> unit +module T : sig + type t [@@deriving show, yojson, compare, sexp, eq, hash] + (** A concrete identifier. *) end -module Kind : sig - type t = - | Type - | Value - | Lifetime - | Constructor of { is_struct : bool } - | Field - | Macro - | Trait - | Impl - | AssociatedItem of t - [@@deriving show, yojson, compare, sexp, eq, hash] -end +include module type of T with type t = T.t -val of_def_id : Kind.t -> Types.def_id -> t -val of_name : Kind.t -> name -> t -val eq_name : name -> t -> bool -val to_debug_string : t -> string +type reserved_suffix = [ `Cast | `Pre | `Post ] +[@@deriving show, yojson, hash, compare, sexp, hash, eq] +(** A concrete identifier can have a reserved suffix: this is useful to derive +new identifiers from existing identifiers. *) -module Create : sig - val parent : t -> t - val fresh_module : from:t list -> t - val move_under : new_parent:t -> t -> t +val of_def_id : + ?suffix:reserved_suffix option -> value:bool -> Types.def_id -> t +(** [of_def_id ?suffix ~value def_id] a concrete identifier out of a Rust +identifier [def_id]. [value] is a flag that decides whether [def_id] +refers to a value or not. - val constructor : t -> t - (** [constructor ident] adds a [Ctor] to [ident] - this allows to build a constructor from a variant name. *) +[value] is important only for constructors: i.e. the identifier for the type +of a struct should be created with [value] set to false while the identifier +for the constructor of a struct should be create with [value] set to true. +For more information, please read the documentation of module +{!Explicit_def_id}. +*) - val map_last : f:(string -> string) -> t -> t - (** [map_last f ident] applies [f] on the last chunk of [ident]'s - path if it holds a string *) +type name = Concrete_ident_generated.t +[@@deriving show, yojson, compare, sexp, eq, hash] +(** A enumeration of static concrete identifiers useful inside the engine. *) - val replace_last : t -> string -> t - (** [replace_last ident chunk] repalces the last chunk of [ident] by [chunk] *) +val of_name : value:bool -> name -> t +(** Creates an identifier given a name. [value] has the same meaning as in function {!of_def_id}. *) - val add_disambiguator : t -> int -> t - (** [add_disambiguator ident d] changes the disambiguator on - the last chunk of [ident]'s path to [d] *) -end +val eq_name : name -> t -> bool +(** [eq_name name identifier] is true whenever [identifier] is [name]. *) -type view = { crate : string; path : string list; definition : string } +val to_debug_string : t -> string +(** Format a identifier as a (ppx) debug string. The default debug pretty prints the identifier. *) -val map_path_strings : f:(string -> string) -> t -> t -val matches_namespace : Types.namespace -> t -> bool +val fresh_module : label:string -> t list -> Fresh_module.t +(** [fresh_module ~label hints] creates a fresh module given a non-empty list of + existing identifiers and a label. The generated module name will be + unique, will be close to the identifiers found in [hints], and will + include the label. +*) -include module type of struct - include Concrete_ident_sig.Make (struct - type t_ = t - type view_ = view - end) -end +val move_to_fresh_module : Fresh_module.t -> t -> t +(** Creates a fresh identifier under a given fresh module and given an existing identifier. *) -module MakeViewAPI (NP : NAME_POLICY) : VIEW_API -module DefaultNamePolicy : NAME_POLICY -module DefaultViewAPI : VIEW_API +val with_suffix : reserved_suffix -> t -> t +(** Creates an identifier out of an existing one, adding a suffix. *) + +val to_view : t -> Concrete_ident_view.t +(** Compute a view for a given identifier. *) + +val map_path_strings : f:(string -> string) -> t -> t +[@@alert unsafe "This function should be only used in Import_thir!"] +(** This function maps any string found in the inner representation of hax. This + is a hack for Import_thir so that we can generically produce identifiers for + any integer type, please do not use it elsewhere. *) type comparator_witness val comparator : (t, comparator_witness) Base.Comparator.comparator -val lookup_raw_impl_info : t -> Types.impl_infos option -(** Lookup the (raw[1]) implementation informations given a concrete -ident. Returns `Some _` if and only if the supplied identifier points -to an `Impl`. +module RenderSig : module type of Concrete_ident_render_sig.Make (T) -[1]: those are raw THIR types. +module type RENDER_API = RenderSig.RENDER_API +module type NAME_POLICY = Concrete_ident_render_sig.NAME_POLICY -{b WARNING}: due to {{: https://github.com/hacspec/hax/issues/363} -issue 363}, when looking up certain identifiers generated by the -engine, this function may return [None] even though the supplied -identifier points to an [Impl] block. *) +module DefaultNamePolicy : NAME_POLICY +module MakeRenderAPI (NP : NAME_POLICY) : RenderSig.RENDER_API +module DefaultViewAPI : RenderSig.RENDER_API -val parent_impl : t -> t option -(** Returns the identifier pointing to the parent `impl` block, if it -exists. *) +module ImplInfoStore : sig + val init : (Types.def_id * Types.impl_infos) list -> unit + + val lookup_raw : t -> Types.impl_infos option + (** Lookup the (raw[1]) implementation informations given a concrete + ident. Returns `Some _` if and only if the supplied identifier points + to an `Impl`. + + [1]: those are raw THIR types. + + {b WARNING}: due to {{: https://github.com/hacspec/hax/issues/363} + issue 363}, when looking up certain identifiers generated by the + engine, this function may return [None] even though the supplied + identifier points to an [Impl] block. *) +end + +val matches_namespace : Types.namespace -> t -> bool diff --git a/engine/lib/concrete_ident/concrete_ident_render_sig.ml b/engine/lib/concrete_ident/concrete_ident_render_sig.ml new file mode 100644 index 000000000..226e3515c --- /dev/null +++ b/engine/lib/concrete_ident/concrete_ident_render_sig.ml @@ -0,0 +1,30 @@ +open! Prelude + +type rendered = { path : string list; name : string } + +module type NAME_POLICY = sig + val reserved_words : string Hash_set.t + (** List of all words that have a special meaning in the target + language, and that should thus be escaped. *) + + val anonymous_field_transform : string -> string + (** Transformation applied to anonymous tuple fields (i.e. [x.1]) *) + + val prefix_struct_constructors_with_type : bool + val prefix_enum_constructors_with_type : bool + val prefix_union_constructors_with_type : bool +end + +module Make (T : sig + type t +end) = +struct + open T + + module type RENDER_API = sig + val show : t -> string + val pp : Formatter.t -> t -> unit + val render : t -> rendered + val local_ident : Local_ident.t -> string + end +end diff --git a/engine/lib/concrete_ident/concrete_ident_sig.ml b/engine/lib/concrete_ident/concrete_ident_sig.ml deleted file mode 100644 index 09af4797a..000000000 --- a/engine/lib/concrete_ident/concrete_ident_sig.ml +++ /dev/null @@ -1,32 +0,0 @@ -open! Prelude - -module Make (T : sig - type t_ - type view_ -end) = -struct - open T - - module type NAME_POLICY = sig - val reserved_words : string Hash_set.t - (** List of all words that have a special meaning in the target - language, and that should thus be escaped. *) - - val index_field_transform : string -> string - (** Transformation applied to indexes fields name (i.e. [x.1]) *) - - val field_name_transform : struct_name:string -> string -> string - val enum_constructor_name_transform : enum_name:string -> string -> string - val struct_constructor_name_transform : string -> string - end - - module type VIEW_API = sig - val show : t_ -> string - val pp : Formatter.t -> t_ -> unit - val to_view : t_ -> view_ - val to_definition_name : t_ -> string - val to_crate_name : t_ -> string - val to_namespace : t_ -> string * string list - val local_ident : Local_ident.t -> string - end -end diff --git a/engine/lib/concrete_ident/concrete_ident_types.ml b/engine/lib/concrete_ident/concrete_ident_types.ml new file mode 100644 index 000000000..74a34fb69 --- /dev/null +++ b/engine/lib/concrete_ident/concrete_ident_types.ml @@ -0,0 +1,75 @@ +open Prelude + +(** An [ExplicitDefId.t] is a Rust [Types.def_id] tagged with some diambiguation metadata. + + Rust raw [Types.def_id] can be ambiguous: consider the following Rust code: + ```rust + struct S; + fn f() -> S { S } + ``` + Here, the return type of `f` (that is, `S`) and the constructor `S` in the body of `f` refers to the exact same identifier `mycrate::S`. + Yet, they denotes two very different objects: a type versus a constructor. + + [ExplicitDefId.t] clears up this ambiguity, making constructors and types two separate things. + + Also, an [ExplicitDefId.t] always points to an item: an [ExplicitDefId.t] is never pointing to a crate alone. +*) +module type ExplicitDefId = sig + type t [@@deriving show, yojson, hash, compare, sexp, hash, eq] + (** Representation of explicit definition identifiers. *) + + val of_def_id : ?constructor:bool -> Types.def_id -> t option + (** Smart constructor for [t]. + Creates an explicit def id out of a raw Rust definition identifier [Types.def_id]. + + When [of_def_id] is called with [id] a [Types.def_id], if the [kind] of [id] is either [Struct] or [Union], then [constructor] is mandatory. + Otherwise, the argument [constructor] should be [true] only if [id] is a variant. + + This function returns [Some] only when those condition are met. + *) + + val make_exn : ?constructor:bool -> Types.def_id -> t + (** Exception-throwing variant of [make]. + This should be used when we know statically that the conditions + described in the documentation of [make] are met. + + For instance, with static [Types.def_id]s or in [Import_thir]. + *) + + val is_constructor : t -> bool + (** Checks wether a definition identifier [id] points to a constructor. + + [is_constructor id] returns [true] when: + - the kind of [id] is [Struct] or [Union] and the identifier was tagged as a constructor; + - the kind of [id] is [Variant]. + Otherwise, [is_constructor id] returns [false]. + *) + + val parent : t -> t option + (** Looks up the parent of a definition identifier. + Note that the parent of the identifier of a field is always a constructor. + + Also, a top-level item (e.g. `my_crate::some_item`) has no parent: recall that [t] represent only items, not crates. + *) + + val parents : t -> t list + (** Ordered list of parents for an identifier [id], starting with [id], up to the top-most parent identifier. *) + + val to_def_id : t -> Types.def_id_contents + (** Destructor for [t]. *) + + module State : sig + val list_all : unit -> t list + (** List all identifiers the engine dealt with so far. Beware, this function is stateful. *) + end +end + +module ViewTypes = struct + type disambiguator = Int64.t + [@@deriving show, hash, compare, sexp, hash, eq, map] + + module DisambiguatedString = struct + type t = { disambiguator : disambiguator; data : string } + [@@deriving show, hash, compare, sexp, hash, eq, map] + end +end diff --git a/engine/lib/concrete_ident/concrete_ident_view.ml b/engine/lib/concrete_ident/concrete_ident_view.ml new file mode 100644 index 000000000..88b16e879 --- /dev/null +++ b/engine/lib/concrete_ident/concrete_ident_view.ml @@ -0,0 +1,202 @@ +open! Prelude +include Concrete_ident_view_types + +(** Rust paths comes with invariants (e.g. a function is always a `ValueNs _`), this function raises an error if a path doesn't respect those. *) +let broken_invariant (type t) msg (did : Explicit_def_id.t) : t = + let msg = + "Explicit_def_id: an invariant have been broken. Expected " ^ msg + ^ ".\n\ndid=" + ^ [%show: Explicit_def_id.t] did + in + Stdio.prerr_endline msg; + failwith msg + +(** Helper module to asserts various properties about a DefId. *) +module Assert = struct + let parent did = + Explicit_def_id.parent did + |> Option.value_or_thunk ~default:(fun _ -> + broken_invariant "the Explicit_def_id to have a parent" did) + + let type_ns (did : Explicit_def_id.t) = + match List.last (Explicit_def_id.to_def_id did).path with + | Some { data = TypeNs data; disambiguator } -> + DisambiguatedString.{ data; disambiguator } + | _ -> broken_invariant "last path chunk to exist and be of type TypeNs" did + + let macro_ns (did : Explicit_def_id.t) = + match List.last (Explicit_def_id.to_def_id did).path with + | Some { data = MacroNs data; disambiguator } -> + DisambiguatedString.{ data; disambiguator } + | _ -> + broken_invariant "last path chunk to exist and be of type MacroNs" did + + let value_ns (did : Explicit_def_id.t) = + match List.last (Explicit_def_id.to_def_id did).path with + | Some { data = ValueNs data; disambiguator } -> + DisambiguatedString.{ data; disambiguator } + | _ -> + broken_invariant "last path chunk to exist and be of type ValueNs" did +end + +let rec poly : + 'n 'd. + into_n:(Explicit_def_id.t -> DisambiguatedString.t -> 'n) -> + into_d:(Explicit_def_id.t -> Int64.t -> 'd) -> + Explicit_def_id.t -> + ('n, 'd) RelPath.Chunk.poly = + fun ~into_n ~into_d did -> + let poly = poly ~into_n ~into_d in + let mk_associated_item kind : ('n, 'd) RelPath.Chunk.poly = + `AssociatedItem + ( kind, + match Assert.parent did |> poly with + | (`Impl _ | `Trait _) as p -> p + | _ -> broken_invariant "Impl or Trait" (Assert.parent did) ) + in + let assert_type_ns did = Assert.type_ns did |> into_n did in + let assert_value_ns did = Assert.value_ns did |> into_n did in + let assert_macro_ns did = Assert.macro_ns did |> into_n did in + let result = + match (Explicit_def_id.to_def_id did).kind with + | (Ctor (Struct, _) | Struct) when Explicit_def_id.is_constructor did -> + let name = assert_type_ns did in + `Constructor (name, `Struct name) + | Variant | Ctor _ -> + let parent = Assert.parent did in + let name = assert_type_ns did in + `Constructor + ( name, + match poly parent with + | (`Enum _ | `Struct _ | `Union _) as p -> p + | _ -> broken_invariant "Enum, Struct or Union" parent ) + | Fn -> `Fn (assert_value_ns did) + | Const -> `Const (assert_value_ns did) + | AssocFn -> `Fn (assert_value_ns did) |> mk_associated_item + | AssocConst -> `Const (assert_value_ns did) |> mk_associated_item + | AssocTy -> `Type (assert_type_ns did) |> mk_associated_item + | Field -> + let constructor = + let parent = Assert.parent did in + match parent |> poly with + | `Constructor _ as p -> p + | _ -> broken_invariant "Constructor" parent + in + `Field (assert_value_ns did, constructor) + | Trait -> `Trait (assert_type_ns did, None) + | TraitAlias -> `Trait (assert_type_ns did, Some `Alias) + | Macro _ -> `Macro (assert_macro_ns did) + | Union -> `Union (assert_type_ns did) + | Enum -> `Enum (assert_type_ns did) + | Struct -> `Struct (assert_type_ns did) + | AnonConst -> + `AnonConst + (match List.last_exn (Explicit_def_id.to_def_id did).path with + | { data = AnonConst; disambiguator } -> into_d did disambiguator + | _ -> broken_invariant "last path chunk to be AnonConst" did) + | Impl { of_trait } -> + `Impl + (match List.last_exn (Explicit_def_id.to_def_id did).path with + | { data = Impl; disambiguator } -> + ( into_d did disambiguator, + (if of_trait then `Trait else `Inherent), + Explicit_def_id.ImplInfoStore.lookup_raw did ) + | _ -> broken_invariant "last path chunk to be Impl" did) + | OpaqueTy -> + `Opaque + (match List.last_exn (Explicit_def_id.to_def_id did).path with + | { data = OpaqueTy; disambiguator } -> into_d did disambiguator + | _ -> broken_invariant "last path chunk to be Opaque" did) + | Use -> + `Use + (match List.last_exn (Explicit_def_id.to_def_id did).path with + | { data = Use; disambiguator } -> into_d did disambiguator + | _ -> broken_invariant "last path chunk to be Use" did) + | ForeignMod -> + `Foreign + (match List.last_exn (Explicit_def_id.to_def_id did).path with + | { data = ForeignMod; disambiguator } -> into_d did disambiguator + | _ -> broken_invariant "last path chunk to be ForeignMod" did) + | ForeignTy -> `ForeignTy (assert_type_ns did) + | ExternCrate -> `ExternCrate (assert_type_ns did) + | Static _ -> `Static (assert_value_ns did) + | Mod -> `Mod (assert_type_ns did) + | GlobalAsm -> + `GlobalAsm + (match List.last_exn (Explicit_def_id.to_def_id did).path with + | { data = GlobalAsm; disambiguator } -> into_d did disambiguator + | _ -> broken_invariant "last path chunk to be GlobalAsm" did) + | TyAlias | TyParam | ConstParam | InlineConst | LifetimeParam | Closure + | SyntheticCoroutineBody -> + (* It should be impossible for such items to ever be referenced by anyting in hax. *) + broken_invariant + "non (TyAlias | TyParam | ConstParam | InlineConst | LifetimeParam | \ + Closure | SyntheticCoroutineBody) identifier" + did + in + result + +let view_name : Explicit_def_id.t -> RelPath.Chunk.t = + poly ~into_n:(fun _ n -> n) ~into_d:(fun _ d -> d) + +let view_name_did : Explicit_def_id.t -> _ RelPath.Chunk.poly = + let mk x y = (x, y) in + poly ~into_n:mk ~into_d:mk + +let of_def_id (did : Explicit_def_id.t) : t = + (* Decompose the parents of a Explicit_def_id, say `a::b::c::d::e`, into: + - `ns_chunks`, the module parents `[a; a::b]` and into + - `rest`, the remaining parents `[a::b::c; a::b::c::d; a::b::c::d::e]` the rest. *) + (* let ns_chunks, rest = + List.split_while + ~f: + ( Explicit_def_id.to_def_id >> fun def_id -> + match def_id.kind with Mod -> true | _ -> false ) + (Explicit_def_id.parents did |> List.rev) + in *) + (* `rest` is a list of identifiers of items nested each in the others. *) + (* We want to process those items begining with most nested one. *) + (* let rest = List.rev rest in *) + (* We distinguish between: + - a chain of identifiers that have a relation with each other (e.g. if `k::E::C` is a constructor and `k::E` a enum) + - a chain of identifiers that have no relation (e.g. `k::f` and `k::f::g` are both functions). + *) + (* This distinguishing is implemented by `poly` (or `view_name_did` and `view_name`) *) + (* From `poly`, we can inspect the root of the chain of identifiers, e.g. `k::E` is the root of `k::E::C`. *) + let ns_chunks, rel_path = + let rec find name_chunks (did : Explicit_def_id.t) = + let is_mod did = + [%matches? (Types.Mod : Types.def_kind)] + (Explicit_def_id.to_def_id did).kind + in + (let*? _did_is_a_mod = is_mod did in + let parents = Explicit_def_id.parents did in + let*? _parents_all_mods = List.for_all ~f:is_mod parents in + Some (List.rev parents, name_chunks)) + |> Option.value_or_thunk ~default:(fun _ -> + let view = view_name_did did in + let did = + view |> RelPath.Chunk.map_poly fst fst |> RelPath.Chunk.root + in + let name_chunks = + RelPath.Chunk.map_poly snd snd view :: name_chunks + in + match Explicit_def_id.parent did with + | None -> ([], name_chunks) + | Some did -> find name_chunks did) + in + find [] did + in + let mod_path : DisambiguatedString.t list = + { data = (Explicit_def_id.to_def_id did).krate; disambiguator = Int64.zero } + :: List.map + ~f:(fun (m : Explicit_def_id.t) -> + match (Explicit_def_id.to_def_id m).path |> List.last_exn with + | Types.{ disambiguator; data = TypeNs data } -> + DisambiguatedString.{ data; disambiguator } + | _ -> + broken_invariant + "A `Mod` identifier must a `TypeNs` as its last path" m) + ns_chunks + in + { rel_path; mod_path } diff --git a/engine/lib/concrete_ident/concrete_ident_view.mli b/engine/lib/concrete_ident/concrete_ident_view.mli new file mode 100644 index 000000000..2a589f72c --- /dev/null +++ b/engine/lib/concrete_ident/concrete_ident_view.mli @@ -0,0 +1,4 @@ +include module type of Concrete_ident_view_types + +val of_def_id : Explicit_def_id.t -> t +(** Computes a view for an explicit definition identifier. *) diff --git a/engine/lib/concrete_ident/concrete_ident_view_types.ml b/engine/lib/concrete_ident/concrete_ident_view_types.ml new file mode 100644 index 000000000..3655fc177 --- /dev/null +++ b/engine/lib/concrete_ident/concrete_ident_view_types.ml @@ -0,0 +1,214 @@ +open! Prelude + +(** This modules defines what is the view over a concrete identifiers. + + Hax manipulates concrete identifiers (that is global identifiers refering to + concrete Rust items -- not built-in operators) as raw Rust identifiers + augmented with some metadata. + + Rust represents identifiers as a crate and a path. Each chunk of the path is + roughly a level of nest in Rust. The path lacks informations about + definition kinds. + + There is two kinds of nesting for items. + - Confort: e.g. the user decides to embed a struct within a function to work + with it locally. + - Relational: e.g. an associated method has to be under a trait, or a field + as to be under a constructor. + + This module provides a view to those paths: a path in the view is a list of + smaller relational paths. For instance, consider the following piece of + code: + + {@rust[ + mod a { + impl MyTrait for MyType { + fn assoc_fn() { + struct LocalStruct { + field: u8, + }; + } + } + } + ]} + + Here, the Rust raw definition identifier of [LocalStruct] is roughly + [a::my_crate::::assoc_fn::LocalStruct::field]. + + The view for [LocalStruct] looks like: + [{ + { + path: ["mycrate"; "a"], + name_path: [ + `AssociatedItem ("assoc_fn", `Impl 0); + `Field ("field", `Constructor ("LocalStruct", `Struct "LocalStruct")) + ] + } + }] +*) + +type disambiguator = Int64.t +[@@deriving show, hash, compare, sexp, hash, eq, map] +(** A [Int64.t] disambiguator: this is given by Rust. *) + +(** A string with a disambiguator. *) +module DisambiguatedString = struct + module T = struct + type t = { disambiguator : disambiguator; data : string } + [@@deriving show, hash, compare, sexp, hash, eq, map] + end + + include T + include Base.Comparator.Make (T) + + let pure data = { disambiguator = Int64.zero; data } +end + +(** A "module and crate"-only path. This is the longest `mod` suffix of a + definition identifier path. This is a list of disambiguated strings. *) +module ModPath = struct + module T = struct + open struct + module T = struct + type t = DisambiguatedString.t list + [@@deriving show, hash, compare, sexp, hash, eq] + end + end + + include T + include Base.Comparator.Make (T) + end + + include T + module Map = Map.M (T) +end + +(** A relational path is a path composed of relational chunks. *) +module RelPath = struct + (** A relational chunk is a short path describing "mandatory" nestings between + items: e.g. a field below a struct, an enum below an enum variants, etc. + + The types defined by this module are indexed by two other types: ['name] and + ['disambiguator]. This helps for instrumenting the view to perform + additional operations: see [collect_either], [collect] and [root]. + *) + module Chunk = struct + type 'name type_definition = + [ `Enum of 'name | `Struct of 'name | `Union of 'name ] + (** A type can be an enum, a struct or a union. A type is standalone: it has no mandatory parent item. *) + + and 'name constructor = [ `Constructor of 'name * 'name type_definition ] + (** A constructor always has a parent type definition. *) + + and 'name maybe_associated = [ `Fn of 'name | `Const of 'name ] + [@@deriving show, hash, compare, sexp, hash, eq, map] + (** Helper type for function and constants: those exists both as associated + in an impl block or a trait, and as standalone. *) + + type 'name associated = [ 'name maybe_associated | `Type of 'name ] + (** An associated item. This is pulled out of [`AssociatedItem] below: + otherwise, some PPX is broken... *) + + and ('name, 'disambiguator) assoc_parent = + [ `Impl of + 'disambiguator * [ `Inherent | `Trait ] * Types.impl_infos option + | `Trait of 'name * [ `Alias ] option ] + [@@deriving show, hash, compare, sexp, hash, eq, map] + (** The parent of an associated item can be an impl or a trait. *) + + type ('name, 'disambiguator) poly = + [ 'name type_definition + | 'name constructor + | 'name maybe_associated + | ('name, 'disambiguator) assoc_parent + | `Use of 'disambiguator + | `AnonConst of 'disambiguator + | `TraitAlias of 'name + | `Foreign of 'disambiguator + | `ForeignTy of 'name + | `ExternCrate of 'name + | `Opaque of 'disambiguator + (** This is e.g.: {[ + fn f() -> impl Clone {} + fn g() { + f(); + } + ]} + Here, the type of `f()` is ``. + *) + | `Static of 'name + | `Macro of 'name + | `AssociatedItem of + 'name associated * ('name, 'disambiguator) assoc_parent + | `Mod of 'name + | `GlobalAsm of 'disambiguator + | `Field of 'name * 'name constructor ] + [@@deriving show, hash, compare, sexp, hash, eq, map] + (** [poly] is the (polymorphic) type for a relational chunk: it defines what is a chunk. *) + + type t = (DisambiguatedString.t, disambiguator) poly + [@@deriving show, hash, compare, sexp, hash, eq] + (** [t] is the natural instantiation of [poly]. *) + + (** Transforms a [t] into a [poly] with annotated strings instead of just + disambiguators. This adds names to the disambiguator-only constructs defined in + [poly]. *) + let add_strings ?(impl = "impl") ?(anon_const = "anon_const") + ?(foreign = "foregin") ?(global_asm = "global_asm") (n : t) : + (DisambiguatedString.t, DisambiguatedString.t) poly = + let f disambiguator = + DisambiguatedString.{ disambiguator; data = impl } + in + match map_poly Fn.id f n with + | `AnonConst o -> `AnonConst { o with data = anon_const } + | `Foreign o -> `Foreign { o with data = foreign } + | `GlobalAsm o -> `GlobalAsm { o with data = global_asm } + | n -> n + + (** Erases names from a [t]. *) + let only_disambiguators : t -> (disambiguator, disambiguator) poly = + map_poly DisambiguatedString.(fun ds -> ds.disambiguator) Fn.id + + (** Collects all the data of a [t], from the child to the parent. *) + let rec collect_either : + 'n 'd. ('n, 'd) poly -> [ `N of 'n | `D of 'd ] list = function + | `Opaque n + | `GlobalAsm n + | `AnonConst n + | `Impl (n, _, _) + | `Use n + | `Foreign n -> + [ `D n ] + | `Static n + | `Macro n + | `Enum n + | `Struct n + | `Union n + | `TraitAlias n + | `Fn n + | `Const n + | `Trait (n, _) + | `ExternCrate n + | `Mod n + | `ForeignTy n -> + [ `N n ] + | `AssociatedItem ((`Fn a | `Const a | `Type a), b) -> + `N a :: collect_either (b :> _ poly) + | `Constructor (a, b) -> `N a :: collect_either (b :> _ poly) + | `Field (a, b) -> `N a :: collect_either (b :> _ poly) + + (** Same as [collect_either], but works on a [poly] whose ['name] and + ['disambiguator] happen to be the same type. *) + let collect : 'a. ('a, 'a) poly -> 'a list = + fun n -> collect_either n |> List.map ~f:(function `D v | `N v -> v) + + (** Find the root of a [poly]. *) + let root : 'a. ('a, 'a) poly -> 'a = fun x -> collect x |> List.last_exn + end + + type t = Chunk.t list [@@deriving show, hash, compare, sexp, hash, eq] +end + +type t = { mod_path : ModPath.t; rel_path : RelPath.t } +[@@deriving show, hash, compare, sexp, hash, eq] +(** Invariant: [name_path] is non-empty *) diff --git a/engine/lib/concrete_ident/explicit_def_id.ml b/engine/lib/concrete_ident/explicit_def_id.ml new file mode 100644 index 000000000..2bc176b7c --- /dev/null +++ b/engine/lib/concrete_ident/explicit_def_id.ml @@ -0,0 +1,127 @@ +open! Prelude + +module T = struct + type t = { is_constructor : bool; def_id : Types.def_id_contents } + [@@deriving show, yojson, sexp] + + type repr = bool * string * Types.disambiguated_def_path_item list + [@@deriving hash, compare, eq] + + let to_repr { is_constructor; def_id } = + (is_constructor, def_id.krate, def_id.path) + + let hash = to_repr >> hash_repr + let hash_fold_t s = to_repr >> hash_fold_repr s + let equal x y = equal_repr (to_repr x) (to_repr y) + let compare x y = compare_repr (to_repr x) (to_repr y) +end + +include T + +(** Helpers for dealing with Rust raw [Types.def_id]s *) +module H = struct + let contents (did : Types.def_id) = did.contents.value + + (** Helper to get the parent of a [Types.def_id_contents] *) + let parent (did : Types.def_id_contents) : Types.def_id_contents option = + Option.map ~f:contents did.parent +end + +(** A pure, def_id_contents version of [of_def_id]. This is not exposed publicly. *) +let pure_of_def_id ?constructor (def_id : Types.def_id_contents) : t option = + let* _not_crate_root = def_id.path |> List.last in + let path_without_ctor = + (* Get rid of extra [Ctor] *) + let* init, last = last_init def_id.path in + let*? _ = [%matches? Types.Ctor] last.data in + Some init + in + let parent = def_id.parent in + let parent = + if Option.is_some path_without_ctor then + let* parent = parent in + (H.contents parent).parent + else parent + in + let path = Option.value path_without_ctor ~default:def_id.path in + let def_id = { def_id with parent; path } in + let constructor = + if Option.is_some path_without_ctor then Some true else constructor + in + let*? _constructor_provided_if_union_or_struct = + not + (Option.is_none constructor + && [%matches? (Union | Struct : Types.def_kind)] def_id.kind) + in + let is_constructor = + [%matches? (Variant : Types.def_kind)] def_id.kind + || [%matches? Some true] constructor + in + Some { is_constructor; def_id } + +module State = struct + let state = Hash_set.create (module T) + + let of_def_id' ?constructor def_id_contents = + let* did = pure_of_def_id ?constructor def_id_contents in + Hash_set.add state did; + Some did + + let of_def_id ?constructor def_id = + of_def_id' ?constructor (H.contents def_id) + + let list_all () = Hash_set.to_list state +end + +let of_def_id = State.of_def_id + +let of_def_id_exn ?constructor def_id = + of_def_id ?constructor def_id |> Option.value_exn + +let parent (did : t) : t option = + let* parent = H.parent did.def_id in + let*? _not_crate_root = List.is_empty parent.path |> not in + let constructor = [%matches? (Field : Types.def_kind)] did.def_id.kind in + State.of_def_id' ~constructor parent + +let rec parents (did : t) = + did :: (parent did |> Option.map ~f:parents |> Option.value ~default:[]) + +let to_def_id { def_id; _ } = def_id +let is_constructor { is_constructor; _ } = is_constructor + +(** Stateful store that maps [def_id]s to implementation informations +(which trait is implemented? for which type? under which constraints?) *) +module ImplInfoStore = struct + let state : (Types.def_id_contents, Types.impl_infos) Hashtbl.t option ref = + ref None + + module T = struct + type t = Types.def_id_contents [@@deriving show, compare, sexp, eq, hash] + end + + let init (impl_infos : (Types.def_id * Types.impl_infos) list) = + state := + impl_infos + |> List.map ~f:(fun ((id : Types.def_id), impl_infos) -> + (id.contents.value, impl_infos)) + |> Hashtbl.of_alist_multi (module T) + |> Hashtbl.map ~f:List.hd_exn |> Option.some + + let get_state () = + match !state with + | None -> failwith "ImplInfoStore was not initialized" + | Some state -> state + + (** Given a [id] of type [def_id], [find id] will return [Some + impl_info] when [id] is an (non-inherent[1]) impl. [impl_info] + contains information about the trait being implemented and for + which type. + + [1]: https://doc.rust-lang.org/reference/items/implementations.html#inherent-implementations + *) + let find k = Hashtbl.find (get_state ()) k + + let lookup_raw (impl_def_id : t) : Types.impl_infos option = + find (to_def_id impl_def_id) +end diff --git a/engine/lib/concrete_ident/explicit_def_id.mli b/engine/lib/concrete_ident/explicit_def_id.mli new file mode 100644 index 000000000..ba67d86d1 --- /dev/null +++ b/engine/lib/concrete_ident/explicit_def_id.mli @@ -0,0 +1,83 @@ +open! Prelude + +(** An [ExplicitDefId.t] is a Rust [Types.def_id] tagged with some diambiguation metadata. + Explicit definition identifiers are used internally by the concrete names of hax. + + Rust raw [Types.def_id] can be ambiguous: consider the following Rust code: + ```rust + struct S; + fn f() -> S { S } + ``` + Here, the return type of `f` (that is, `S`) and the constructor `S` in the body of `f` refers to the exact same identifier `mycrate::S`. + Yet, they denotes two very different objects: a type versus a constructor. + + [ExplicitDefId.t] clears up this ambiguity, making constructors and types two separate things. + + Also, an [ExplicitDefId.t] always points to an item: an [ExplicitDefId.t] is never pointing to a crate alone. +*) + +type t [@@deriving show, yojson, hash, compare, sexp, hash, eq] +(** Representation of explicit definition identifiers. *) + +val of_def_id : ?constructor:bool -> Types.def_id -> t option +(** Smart constructor for [t]. + Creates an explicit def id out of a raw Rust definition identifier [Types.def_id]. + + When [of_def_id] is called with [id] a [Types.def_id], if the [kind] of [id] is either [Struct] or [Union], then [constructor] is mandatory. + Otherwise, the argument [constructor] should be [true] only if [id] is a variant. + + [of_def_id] shall not be called on a Rust identifier pointing to a crate root. + + This function returns [Some] only when those condition are met. + *) + +val of_def_id_exn : ?constructor:bool -> Types.def_id -> t +(** Exception-throwing variant of [make]. + This should be used when we know statically that the conditions + described in the documentation of [make] are met. + + For instance, with static [Types.def_id]s or in [Import_thir]. + *) + +val is_constructor : t -> bool +(** Checks wether a definition identifier [id] points to a constructor. + + [is_constructor id] returns [true] when: + - the kind of [id] is [Struct] or [Union] and the identifier was tagged as a constructor; + - the kind of [id] is [Variant]. + Otherwise, [is_constructor id] returns [false]. + *) + +val parent : t -> t option +(** Looks up the parent of a definition identifier. + Note that the parent of the identifier of a field is always a constructor. + + Also, a top-level item (e.g. `my_crate::some_item`) has no parent: recall that [t] represent only items, not crates. + *) + +val parents : t -> t list +(** Ordered list of parents for an identifier [id], starting with [id], up to the top-most parent identifier. *) + +val to_def_id : t -> Types.def_id_contents +(** Destructor for [t]. *) + +module State : sig + val list_all : unit -> t list + (** List all identifiers the engine dealt with so far. Beware, this function is stateful. *) +end + +module ImplInfoStore : sig + val init : (Types.def_id * Types.impl_infos) list -> unit + + val lookup_raw : t -> Types.impl_infos option + (** Lookup the (raw[1]) implementation informations given a concrete + ident. Returns `Some _` if and only if the supplied identifier points + to an `Impl`. + + [1]: those are raw THIR types. + + {b WARNING}: due to {{: https://github.com/hacspec/hax/issues/363} + issue 363}, when looking up certain identifiers generated by the + engine, this function may return [None] even though the supplied + identifier points to an [Impl] block. *) +end diff --git a/engine/lib/concrete_ident/impl_infos.ml b/engine/lib/concrete_ident/impl_infos.ml index 175d058d1..995cc1a16 100644 --- a/engine/lib/concrete_ident/impl_infos.ml +++ b/engine/lib/concrete_ident/impl_infos.ml @@ -21,7 +21,7 @@ engine, this function may return [None] even though the supplied identifier points to an [Impl] block. *) let lookup span (impl : Concrete_ident.t) : t option = let* Types.{ generics = _; clauses; typ; trait_ref } = - Concrete_ident.lookup_raw_impl_info impl + Concrete_ident.ImplInfoStore.lookup_raw impl in let trait_goal = Option.map ~f:(Import_thir.import_trait_ref span) trait_ref diff --git a/engine/lib/concrete_ident/thir_simple_types.ml b/engine/lib/concrete_ident/thir_simple_types.ml new file mode 100644 index 000000000..55b7fbe28 --- /dev/null +++ b/engine/lib/concrete_ident/thir_simple_types.ml @@ -0,0 +1,78 @@ +open! Prelude +module View = Concrete_ident_view + +(** Interprets a type as a "simple type". + A simple type is a type for which, in a given scope, we can give a non-ambiguous string identifier. + + This is useful for naming local impls. + + Examples of "simple" types: + - primitive types (e.g. u8, u16) + - enums/structs/unions defined in [namespace], when: + + all their generic arguments are instantiated to a simple type + - a reference to a simple type + - a slice to a simple type + - a tuple of simple types of arity zero (e.g. no ADTs of non-zero arity) +*) +let to_string ~(namespace : View.ModPath.t) : + Types.node_for__ty_kind -> string option = + let escape = + let re = Re.Pcre.regexp "_((?:e_)*)of_" in + let f group = "_e_" ^ Re.Group.get group 1 ^ "of_" in + Re.replace ~all:true re ~f + in + let adt def_id = + let* def_id = Explicit_def_id.of_def_id ~constructor:false def_id in + let view = View.of_def_id def_id in + let* () = + [%equal: View.ModPath.t] view.mod_path namespace |> some_if_true + in + let* last = expect_singleton view.rel_path in + let* name = + match last with + | (`Struct d | `Union d | `Enum d) + when Int64.(equal (of_int 0) d.disambiguator) -> + Some d.data + | _ -> None + in + escape name |> Option.some + in + let arity0 (ty : Types.node_for__ty_kind) = + match ty.Types.value with + | Bool -> Some "bool" + | Char -> Some "char" + | Str -> Some "str" + | Never -> Some "never" + | Int Isize -> Some "isize" + | Int I8 -> Some "i8" + | Int I16 -> Some "i16" + | Int I32 -> Some "i32" + | Int I64 -> Some "i64" + | Int I128 -> Some "i128" + | Uint Usize -> Some "usize" + | Uint U8 -> Some "u8" + | Uint U16 -> Some "u16" + | Uint U32 -> Some "u32" + | Uint U64 -> Some "u64" + | Uint U128 -> Some "u128" + | Float F32 -> Some "f32" + | Float F64 -> Some "f64" + | Tuple [] -> Some "unit" + | Adt { def_id; generic_args = []; _ } -> Option.map ~f:escape (adt def_id) + | _ -> None + in + let apply left right = left ^ "_of_" ^ right in + let rec arity1 (ty : Types.node_for__ty_kind) = + match ty.value with + | Slice sub -> arity1 sub |> Option.map ~f:(apply "slice") + | Ref (_, sub, _) -> arity1 sub |> Option.map ~f:(apply "ref") + | Adt { def_id; generic_args = [ Type arg ]; _ } -> + let* adt = adt def_id in + let* arg = arity1 arg in + Some (apply adt arg) + | Tuple l -> + let* l = List.map ~f:arity0 l |> Option.all in + Some ("tuple_" ^ String.concat ~sep:"_" l) + | _ -> arity0 ty + in + arity1 diff --git a/engine/lib/dependencies.ml b/engine/lib/dependencies.ml index e314571a1..258f91daf 100644 --- a/engine/lib/dependencies.ml +++ b/engine/lib/dependencies.ml @@ -6,25 +6,45 @@ module Make (F : Features.T) = struct open Ast open AST - let ident_of (item : item) : Concrete_ident.t = - match item.v with Type { name; _ } -> name | _ -> item.ident + (** Get the identifier of an item *) + let ident_of (item : item) : Concrete_ident.t = item.ident + + (** Get all the identifiers declared under an item. This includes the + identifier of the item itself, but also of any sub-item: for instance, + associated items within an impl. *) + let idents_of (item : item) : Concrete_ident.t list = + let is_field_anonymous ident = + match List.last (Concrete_ident.to_view ident).mod_path with + | Some { data = n; _ } -> Option.is_some (Int.of_string_opt n) + | _ -> false + in + ident_of item + :: + (match item.v with + | Type { variants; _ } -> + List.concat_map + ~f:(fun variant -> + let fields = + List.map ~f:fst3 variant.arguments + |> List.filter ~f:is_field_anonymous + in + + variant.name :: fields) + variants + | Trait { items; _ } -> List.map ~f:(fun item -> item.ti_ident) items + | Impl { items; _ } -> List.map ~f:(fun item -> item.ii_ident) items + | _ -> (* No sub items *) []) module Namespace = struct - module T = struct - type t = string list [@@deriving show, yojson, compare, sexp, eq, hash] - end - - module TT = struct - include T - include Comparator.Make (T) - end + include Concrete_ident.View.ModPath + module Set = Set.M (Concrete_ident.View.ModPath) - include TT - module Set = Set.M (TT) + let of_concrete_ident ci : t = (Concrete_ident.to_view ci).mod_path - let of_concrete_ident ci : t = - let krate, path = Concrete_ident.DefaultViewAPI.to_namespace ci in - krate :: path + let to_string ?(sep = "::") : t -> string = + List.map ~f:(fun (o : Concrete_ident_view.DisambiguatedString.t) -> + o.data) + >> String.concat ~sep end module Error : Phase_utils.ERROR = Phase_utils.MakeError (struct @@ -180,13 +200,12 @@ module Make (F : Features.T) = struct (mod_graph_cycles : Namespace.Set.t list) : Bundle.t list = let item_names = List.map items ~f:(fun x -> x.ident) in let cycles = - List.filter mod_graph_cycles ~f:(fun set -> - Prelude.Set.length set > 1) + List.filter mod_graph_cycles ~f:(fun set -> Set.length set > 1) in let bundles = List.map cycles ~f:(fun set -> List.filter item_names ~f:(fun item -> - Prelude.Set.mem set (Namespace.of_concrete_ident item))) + Set.mem set (Namespace.of_concrete_ident item))) in bundles end @@ -199,12 +218,12 @@ module Make (F : Features.T) = struct let vertex_name i = "\"" ^ Concrete_ident.show i ^ "\"" let vertex_attributes i = - [ `Label (Concrete_ident.DefaultViewAPI.to_definition_name i) ] + [ `Label (Concrete_ident.DefaultViewAPI.render i).name ] let get_subgraph i = let ns = Namespace.of_concrete_ident i in - let sg_name = String.concat ~sep:"__" ns in - let label = String.concat ~sep:"::" ns in + let sg_name = Namespace.to_string ~sep:"__" ns in + let label = Namespace.to_string ~sep:"::" ns in let open Graph.Graphviz.DotAttributes in Some { sg_name; sg_attributes = [ `Label label ]; sg_parent = None } @@ -253,7 +272,7 @@ module Make (F : Features.T) = struct let graph_attributes _ = [] let default_vertex_attributes _ = [] - let vertex_name ns = "\"" ^ String.concat ~sep:"::" ns ^ "\"" + let vertex_name ns = "\"" ^ Namespace.to_string ns ^ "\"" let vertex_attributes _ = [] let get_subgraph _ = None let default_edge_attributes _ = [] @@ -373,8 +392,7 @@ module Make (F : Features.T) = struct let global_sort (items : item list) : item list = let sorted_by_namespace = - U.group_items_by_namespace_generic - Concrete_ident.DefaultViewAPI.to_namespace items + U.group_items_by_namespace items |> Map.data |> List.map ~f:(fun items -> sort items) in @@ -473,111 +491,41 @@ module Make (F : Features.T) = struct in List.filter ~f:(ident_of >> Set.mem selection) items - (* Construct the new item `f item` (say `item'`), and create a - "symbolic link" to `item'`. Returns a pair that consists in the - symbolic link and in `item'`. *) - let shallow_copy (f : item -> item) - (variants_renamings : - concrete_ident * concrete_ident -> - (concrete_ident * concrete_ident) list) (item : item) : item list = - let item' = f item in - let old_new = (ident_of item, ident_of item') in + let fresh_module_for (bundle : item list) = + let fresh_module = + Concrete_ident.fresh_module ~label:"bundle" (List.map ~f:ident_of bundle) + in + let renamings = + bundle + (* Exclude `Use` items: we exclude those from bundling since they are only + user hints. `Use` items don't have proper identifiers, and those + identifiers are never referenced by other Rust items. *) + |> List.filter ~f:(function { v = Use _; _ } -> false | _ -> true) + (* Exclude `NotImplementedYet` items *) + |> List.filter ~f:(function + | { v = NotImplementedYet; _ } -> false + | _ -> true) + |> List.concat_map ~f:(fun item -> + List.map + ~f:(fun id -> + ( item, + (id, Concrete_ident.move_to_fresh_module fresh_module id) )) + (idents_of item)) + in let aliases = - List.map (old_new :: variants_renamings old_new) - ~f:(fun (old_ident, new_ident) -> + List.map renamings ~f:(fun (origin_item, (from_id, to_id)) -> let attrs = - List.filter ~f:(fun att -> Attrs.late_skip [ att ]) item.attrs + List.filter + ~f:(fun att -> Attrs.late_skip [ att ]) + origin_item.attrs in - - { - item with - v = Alias { name = old_ident; item = new_ident }; - attrs; - ident = old_ident; - }) - in - item' :: aliases - - let bundle_cyclic_modules (items : item list) : item list = - let from_ident ident : item option = - List.find ~f:(fun i -> [%equal: Concrete_ident.t] i.ident ident) items + let v = Alias { name = from_id; item = to_id } in + { attrs; span = origin_item.span; ident = from_id; v }) in - let mut_rec_bundles = - let mod_graph_cycles = ModGraph.of_items items |> ModGraph.cycles in - (* `Use` items shouldn't be bundled as they have no dependencies - and they have dummy names. *) - let non_use_items = - List.filter - ~f:(fun item -> - match item.v with Use _ | NotImplementedYet -> false | _ -> true) - items - in - let bundles = - ItemGraph.CyclicDep.of_mod_sccs non_use_items mod_graph_cycles - in - let f = List.filter_map ~f:from_ident in - List.map ~f bundles - in - - let transform (bundle : item list) = - let module_names = - List.map ~f:(ident_of >> Concrete_ident.Create.parent) bundle - |> List.dedup_and_sort ~compare:Concrete_ident.compare - in - let ns : Concrete_ident.t = - Concrete_ident.Create.fresh_module ~from:module_names - in - let new_name_under_ns : Concrete_ident.t -> Concrete_ident.t = - Concrete_ident.Create.move_under ~new_parent:ns - in - let new_names = List.map ~f:(ident_of >> new_name_under_ns) bundle in - let duplicates = - new_names |> List.find_all_dups ~compare:Concrete_ident.compare - in - (* Verify name clashes *) - (* In case of clash, add hash *) - let add_prefix id = - if - not - (List.mem duplicates (new_name_under_ns id) - ~equal:Concrete_ident.equal) - then id - else Concrete_ident.Create.add_disambiguator id (Concrete_ident.hash id) - in + let rename = + let renamings = List.map ~f:snd renamings in let renamings = - List.map - ~f:(ident_of >> (Fn.id &&& (add_prefix >> new_name_under_ns))) - bundle - in - let variants_renamings (previous_name, new_name) = - match from_ident previous_name with - | Some { v = Type { variants; is_struct = false; _ }; _ } -> - List.map variants ~f:(fun { name; _ } -> - ( name, - Concrete_ident.Create.move_under ~new_parent:new_name name )) - | Some { v = Type { variants; is_struct = true; _ }; _ } -> - List.concat_map variants ~f:(fun { arguments; _ } -> - List.map arguments ~f:(fun (name, _, _) -> - ( name, - Concrete_ident.Create.move_under ~new_parent:new_name name - ))) - | _ -> [] - in - let variant_and_constructors_renamings = - List.concat_map ~f:variants_renamings renamings - |> List.concat_map ~f:(fun (old_name, new_name) -> - [ - (old_name, new_name); - ( Concrete_ident.Create.constructor old_name, - Concrete_ident.Create.constructor new_name ); - ]) - in - let renamings = - match - Map.of_alist - (module Concrete_ident) - (renamings @ variant_and_constructors_renamings) - with + match Map.of_alist (module Concrete_ident) renamings with | `Duplicate_key dup -> failwith [%string @@ -587,47 +535,25 @@ module Make (F : Features.T) = struct %{[%show: concrete_ident] dup}"] | `Ok value -> value in - let rename = - let renamer _lvl i = Map.find renamings i |> Option.value ~default:i in - (U.Mappers.rename_concrete_idents renamer)#visit_item ExprLevel - in - fun it -> shallow_copy rename variants_renamings it - in - let bundle_transforms = - List.concat_map mut_rec_bundles ~f:(fun bundle -> - let bundle_value = - ( List.map ~f:ident_of bundle - |> ItemGraph.MutRec.Bundle.homogeneous_namespace, - transform bundle ) - in - List.map bundle ~f:(fun item -> (item, bundle_value))) + let renamer _lvl i = Map.find renamings i |> Option.value ~default:i in + (U.Mappers.rename_concrete_idents renamer)#visit_item ExprLevel in - let module ComparableItem = struct - module T = struct - type t = item [@@deriving sexp_of, compare, hash] - end + List.map ~f:rename bundle @ aliases - include T - include Comparable.Make (T) - end in - let bundle_of_item = - match Hashtbl.of_alist (module ComparableItem) bundle_transforms with - | `Duplicate_key dup -> - failwith - [%string - "Fatal error: in dependency analysis, [bundles_transforms] is \ - expected to be a key-value list with a guarantee of unicity in \ - keys. However, we found the following key (an item) twice:\n\ - %{U.Debug.item' dup}"] - | `Ok value -> value - in - let maybe_transform_item item = - match Hashtbl.find bundle_of_item item with - | Some (homogeneous_bundle, transform_bundle) -> - if homogeneous_bundle then [ item ] else transform_bundle item - | None -> [ item ] + let bundle_cyclic_modules (items : item list) : item list = + (* [module_level_scc] is a list of set of strongly connected modules. *) + let module_level_scc = ModGraph.(of_items >> cycles) items in + let items_per_ns = + List.map ~f:(fun i -> (Namespace.of_concrete_ident i.ident, i)) items + |> Map.of_alist_multi (module Namespace) in - List.concat_map items ~f:maybe_transform_item + let items_of_ns = Map.find items_per_ns >> Option.value ~default:[] in + module_level_scc + |> List.concat_map ~f:(fun nss -> + let multiple_heterogeneous_modules = Set.length nss > 1 in + let items = Set.to_list nss |> List.concat_map ~f:items_of_ns in + if multiple_heterogeneous_modules then fresh_module_for items + else items) let recursive_bundles (items : item list) : item list list * item list = let g = ItemGraph.of_items ~original_items:items items in diff --git a/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml index 37fe9bc4c..4b52400d7 100644 --- a/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml +++ b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml @@ -1,7 +1,7 @@ open! Prelude open! Ast -module Make (F : Features.T) (View : Concrete_ident.VIEW_API) = struct +module Make (F : Features.T) (View : Concrete_ident.RENDER_API) = struct open Deprecated_generic_printer_base open Deprecated_generic_printer_base.Make (F) @@ -31,19 +31,20 @@ module Make (F : Features.T) (View : Concrete_ident.VIEW_API) = struct method namespace_of_concrete_ident : concrete_ident -> string * string list = - fun i -> View.to_namespace i + fun i -> + let rendered = View.render i in + (rendered.name, rendered.path) method concrete_ident' ~(under_current_ns : bool) : concrete_ident fn = fun id -> - let id = View.to_view id in + let id = View.render id in let chunks = - if under_current_ns then [ id.definition ] - else id.crate :: (id.path @ [ id.definition ]) + if under_current_ns then [ id.name ] else id.path @ [ id.name ] in separate_map (colon ^^ colon) utf8string chunks method name_of_concrete_ident : concrete_ident fn = - View.to_definition_name >> utf8string + fun id -> (View.render id).name |> utf8string method mutability : 'a. 'a mutability fn = fun _ -> empty diff --git a/engine/lib/deprecated_generic_printer/deprecated_generic_printer.mli b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.mli index 3eb3904f6..fdf32ccba 100644 --- a/engine/lib/deprecated_generic_printer/deprecated_generic_printer.mli +++ b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.mli @@ -1,4 +1,4 @@ -module Make (F : Features.T) (View : Concrete_ident.VIEW_API) : sig +module Make (F : Features.T) (View : Concrete_ident.RENDER_API) : sig open Deprecated_generic_printer_base.Make(F) include API diff --git a/engine/lib/dune b/engine/lib/dune index 17a3db14d..cf6396636 100644 --- a/engine/lib/dune +++ b/engine/lib/dune @@ -1,6 +1,19 @@ (library (public_name hax-engine) (name hax_engine) + ; (modules + ; types + ; concrete_ident + ; concrete_ident_view + ; concrete_ident_defid + ; prelude + ; concrete_ident_view_types + ; concrete_ident_generated + ; concrete_ident_render_sig + ; local_ident + ; thir_simple_types + ; concrete_ident_fresh_ns + ; utils) (libraries yojson non_empty_list @@ -32,6 +45,7 @@ ppx_generate_features ppx_functor_application ppx_enumerate + ppx_deriving.map ppx_matches))) (include_subdirs unqualified) diff --git a/engine/lib/generic_printer/generic_printer.ml b/engine/lib/generic_printer/generic_printer.ml index 81a5c793f..cd8370205 100644 --- a/engine/lib/generic_printer/generic_printer.ml +++ b/engine/lib/generic_printer/generic_printer.ml @@ -171,7 +171,7 @@ module Make (F : Features.T) = struct object (self) inherit Gen.base as super inherit span_helper - val mutable current_namespace : (string * string list) option = None + val mutable current_namespace : string list option = None method private catch_exn (handle : string -> document) (f : unit -> document) : document = @@ -192,7 +192,7 @@ module Make (F : Features.T) = struct method virtual printer_name : string (** Mark a path as unreachable *) - val concrete_ident_view : (module Concrete_ident.VIEW_API) = + val concrete_ident_view : (module Concrete_ident.RENDER_API) = (module Concrete_ident.DefaultViewAPI) (** The concrete ident view to be used *) @@ -221,12 +221,13 @@ module Make (F : Features.T) = struct |> string (** {2:specialize-expr Printers for special types} *) - method concrete_ident ~local (id : Concrete_ident.view) : document = + method concrete_ident ~local (id : Concrete_ident_render_sig.rendered) + : document = string - (if local then id.definition + (if local then id.name else String.concat ~sep:self#module_path_separator - (id.crate :: (id.path @ [ id.definition ]))) + (id.path @ [ id.name ])) (** [concrete_ident ~local id] prints a name without path if [local] is true, otherwise it prints the full path, separated by `module_path_separator`. *) @@ -601,13 +602,9 @@ module Make (F : Features.T) = struct lazy_doc (fun (id : concrete_ident) -> let module View = (val concrete_ident_view) in - let id = View.to_view id in - let ns_crate, ns_path = - Option.value ~default:("", []) current_namespace - in - let local = - String.(ns_crate = id.crate) && [%eq: string list] ns_path id.path - in + let id = View.render id in + let ns_path = Option.value ~default:[] current_namespace in + let local = [%eq: string list] ns_path id.path in self#concrete_ident ~local id) ast_position id @@ -630,7 +627,7 @@ module Make (F : Features.T) = struct method! _do_not_override_lazy_of_item ast_position (value : item) : item lazy_doc = let module View = (val concrete_ident_view) in - current_namespace <- View.to_namespace value.ident |> Option.some; + current_namespace <- Some (View.render value.ident).path; super#_do_not_override_lazy_of_item ast_position value method _do_not_override_lazy_of_generics ast_position (value : generics) diff --git a/engine/lib/import_thir.ml b/engine/lib/import_thir.ml index 2a47901ac..ef3bfa341 100644 --- a/engine/lib/import_thir.ml +++ b/engine/lib/import_thir.ml @@ -39,8 +39,8 @@ module U = Ast_utils.Make (Features.Rust) module W = Features.On open Ast -let def_id kind (def_id : Thir.def_id) : global_ident = - `Concrete (Concrete_ident.of_def_id kind def_id) +let def_id ~value (def_id : Thir.def_id) : global_ident = + `Concrete (Concrete_ident.of_def_id ~value def_id) let local_ident kind (ident : Thir.local_ident) : local_ident = { @@ -220,8 +220,7 @@ let resugar_index_mut (e : expr) : (expr * expr) option = | _ -> None (** Name for the cast function from an ADT to its discriminant *) -let cast_name_for_type typ_name = - Concrete_ident.Create.map_last ~f:(fun s -> s ^ "_cast_to_repr") typ_name +let cast_name_for_type = Concrete_ident.with_suffix `Cast module type EXPR = sig val c_expr : Thir.decorated_for__expr_kind -> expr @@ -343,15 +342,15 @@ end) : EXPR = struct in match f (lhs.typ, rhs.typ) with | Some with_ -> - Concrete_ident.of_name Value name - |> Concrete_ident.map_path_strings ~f:(function + Concrete_ident.of_name ~value:true name + |> (Concrete_ident.map_path_strings [@alert "-unsafe"]) ~f:(function | "u128" -> with_ | s -> s) | None -> assertion_failure (Span.to_thir span) ("Binary operation: expected " ^ expected ^ " type, got " ^ [%show: ty] lhs.typ) - else Concrete_ident.of_name Value @@ overloaded_names_of_binop op + else Concrete_ident.of_name ~value:true @@ overloaded_names_of_binop op in U.call' (`Concrete name) [ lhs; rhs ] span typ @@ -372,7 +371,9 @@ end) : EXPR = struct and c_expr_drop_body (e : Thir.decorated_for__expr_kind) : expr = let typ = c_ty e.span e.ty in let span = Span.of_thir e.span in - let v = Global_ident.of_name Value Rust_primitives__hax__dropped_body in + let v = + Global_ident.of_name ~value:true Rust_primitives__hax__dropped_body + in { span; typ; e = GlobalVar v } and c_block ~expr ~span ~stmts ~ty ~(safety_mode : Types.block_safety) : expr @@ -472,7 +473,7 @@ end) : EXPR = struct MacroInvokation { args = argument; - macro = def_id Macro macro_ident; + macro = def_id ~value:false macro_ident; witness = W.macro; } | If @@ -519,7 +520,7 @@ end) : EXPR = struct let f = c_expr fun' in match (trait, fun'.contents) with | Some _, GlobalName { id; _ } -> - { f with e = GlobalVar (def_id (AssociatedItem Value) id) } + { f with e = GlobalVar (def_id ~value:true id) } | _ -> f in let args = if List.is_empty args then [ unit_expr span ] else args in @@ -610,7 +611,8 @@ end) : EXPR = struct let lhs = c_expr lhs in let projector = GlobalVar - (`Projector (`Concrete (Concrete_ident.of_def_id Field field))) + (`Projector + (`Concrete (Concrete_ident.of_def_id ~value:true field))) in let span = Span.of_thir e.span in App @@ -638,15 +640,7 @@ end) : EXPR = struct trait = None (* TODO: see issue #328 *); bounds_impls = []; } - | GlobalName { id; constructor } -> - let kind = - match constructor with - | Some { kind = Struct _; _ } -> - Concrete_ident.Kind.Constructor { is_struct = true } - | Some _ -> Concrete_ident.Kind.Constructor { is_struct = false } - | None -> Concrete_ident.Kind.Value - in - GlobalVar (def_id kind id) + | GlobalName { id; constructor = _ } -> GlobalVar (def_id ~value:true id) | UpvarRef { var_hir_id = id; _ } -> LocalVar (local_ident Expr id) | Borrow { arg; borrow_kind = kind } -> let e' = c_expr arg in @@ -702,7 +696,7 @@ end) : EXPR = struct unimplemented ~issue_id:998 [ e.span ] "Construct union types: not supported" in - let constructor = def_id (Constructor { is_struct }) info.variant in + let constructor = def_id ~value:true info.variant in let base = Option.map ~f:(fun base -> (c_expr base.base, W.construct_base)) @@ -711,7 +705,7 @@ end) : EXPR = struct let fields = List.map ~f:(fun f -> - let field = def_id Field f.field in + let field = def_id ~value:true f.field in let value = c_expr f.value in (field, value)) fields @@ -731,10 +725,7 @@ end) : EXPR = struct }) l)) | NamedConst { def_id = id; impl; args; _ } -> ( - let kind : Concrete_ident.Kind.t = - match impl with Some _ -> AssociatedItem Value | _ -> Value - in - let f = GlobalVar (def_id kind id) in + let f = GlobalVar (def_id ~value:true id) in match impl with | Some impl -> let trait = @@ -762,9 +753,9 @@ end) : EXPR = struct let lhs_type = c_ty lhs.span lhs.ty in call (mk_global ([ lhs_type; index_type ] ->. typ) - @@ Global_ident.of_name Value Core__ops__index__Index__index) + @@ Global_ident.of_name ~value:true Core__ops__index__Index__index) [ lhs; index ] - | StaticRef { def_id = id; _ } -> GlobalVar (def_id Value id) + | StaticRef { def_id = id; _ } -> GlobalVar (def_id ~value:true id) | PlaceTypeAscription _ -> assertion_failure [ e.span ] "Got a unexpected node `PlaceTypeAscription`. Please report, we \ @@ -900,7 +891,7 @@ end) : EXPR = struct unimplemented ~issue_id:998 [ pat.span ] "Pattern match on union types: not supported" in - let constructor = def_id (Constructor { is_struct }) info.variant in + let constructor = def_id ~value:true info.variant in let fields = List.map ~f:(c_field_pat info) subpatterns in PConstruct { constructor; fields; is_record; is_struct } | Tuple { subpatterns } -> @@ -937,7 +928,10 @@ end) : EXPR = struct { p = v; span; typ } and c_field_pat _info (field_pat : Thir.field_pat) : field_pat = - { field = def_id Field field_pat.field; pat = c_pat field_pat.pattern } + { + field = def_id ~value:true field_pat.field; + pat = c_pat field_pat.pattern; + } and extended_literal_of_expr (e : expr) : extended_literal = let not_a_literal () = @@ -1016,7 +1010,7 @@ end) : EXPR = struct in TArrow (inputs, c_ty span output) | Adt { def_id = id; generic_args; _ } -> - let ident = def_id Type id in + let ident = def_id ~value:false id in let args = List.map ~f:(c_generic_value span) generic_args in TApp { ident; args } | Foreign _ -> unimplemented ~issue_id:928 [ span ] "Foreign" @@ -1037,10 +1031,10 @@ end) : EXPR = struct TApp { ident = `TupleType (List.length types); args = types } | Alias { kind = Projection { assoc_item = _; impl_expr }; def_id; _ } -> let impl = c_impl_expr span impl_expr in - let item = Concrete_ident.of_def_id (AssociatedItem Type) def_id in + let item = Concrete_ident.of_def_id ~value:false def_id in TAssociatedType { impl; item } | Alias { kind = Opaque _; def_id; _ } -> - TOpaque (Concrete_ident.of_def_id Type def_id) + TOpaque (Concrete_ident.of_def_id ~value:false def_id) | Alias { kind = Inherent; _ } -> assertion_failure [ span ] "Ty::Alias with AliasTyKind::Inherent" | Alias { kind = Weak; _ } -> @@ -1068,7 +1062,7 @@ end) : EXPR = struct | Trait { args; def_id } -> let goal : dyn_trait_goal = { - trait = Concrete_ident.of_def_id Trait def_id; + trait = Concrete_ident.of_def_id ~value:false def_id; non_self_args = List.map ~f:(c_generic_value span) args; } in @@ -1107,7 +1101,7 @@ end) : EXPR = struct | _ -> impl and c_trait_ref span (tr : Thir.trait_ref) : trait_goal = - let trait = Concrete_ident.of_def_id Trait tr.def_id in + let trait = Concrete_ident.of_def_id ~value:false tr.def_id in let args = List.map ~f:(c_generic_value span) tr.generic_args in { trait; args } @@ -1122,10 +1116,7 @@ end) : EXPR = struct let ident = { goal = c_trait_ref span trait_ref; name = predicate_id } in - let kind : Concrete_ident.Kind.t = - match item.kind with Const | Fn -> Value | Type -> Type - in - let item = Concrete_ident.of_def_id kind item.def_id in + let item = Concrete_ident.of_def_id ~value:false item.def_id in let trait_ref = c_trait_ref span trait_ref in Projection { impl = { kind = item_kind; goal = trait_ref }; ident; item } @@ -1139,7 +1130,7 @@ end) : EXPR = struct in match ie with | Concrete { id; generics; _ } -> - let trait = Concrete_ident.of_def_id Impl id in + let trait = Concrete_ident.of_def_id ~value:false id in let args = List.map ~f:(c_generic_value span) generics in Concrete { trait; args } | LocalBound { predicate_id; path; _ } -> @@ -1235,12 +1226,12 @@ end) : EXPR = struct match kind with | Trait { is_positive = true; trait_ref } -> let args = List.map ~f:(c_generic_value span) trait_ref.generic_args in - let trait = Concrete_ident.of_def_id Trait trait_ref.def_id in + let trait = Concrete_ident.of_def_id ~value:false trait_ref.def_id in Some (GCType { goal = { trait; args }; name = id }) | Projection { impl_expr; assoc_item; ty } -> let impl = c_impl_expr span impl_expr in let assoc_item = - Concrete_ident.of_def_id (AssociatedItem Type) assoc_item.def_id + Concrete_ident.of_def_id ~value:false assoc_item.def_id in let typ = c_ty span ty in Some (GCProjection { impl; assoc_item; typ }) @@ -1336,7 +1327,7 @@ let c_trait_item (item : Thir.trait_item) : trait_item = let open (val make ~krate:item.owner_id.contents.value.krate : EXPR) in let { params; constraints } = c_generics item.generics in (* TODO: see TODO in impl items *) - let ti_ident = Concrete_ident.of_def_id Field item.owner_id in + let ti_ident = Concrete_ident.of_def_id ~value:false item.owner_id in { ti_span = Span.of_thir item.span; ti_generics = { params; constraints }; @@ -1419,7 +1410,9 @@ let cast_of_enum typ_name generics typ thir_span let acc = Lit Int64.(n + m) in (acc, (pat, acc)) | _, Explicit did -> - let acc = Exp { e = GlobalVar (def_id Value did); span; typ } in + let acc = + Exp { e = GlobalVar (def_id ~value:true did); span; typ } + in (acc, (pat, acc)) | Exp e, Relative n -> let acc = @@ -1525,7 +1518,7 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = mk @@ Fn { - name = Concrete_ident.of_def_id Value (assert_item_def_id ()); + name = Concrete_ident.of_def_id ~value:true (assert_item_def_id ()); generics = c_generics generics; body = c_body body; params = []; @@ -1535,7 +1528,8 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = mk @@ TyAlias { - name = Concrete_ident.of_def_id Type (assert_item_def_id ()); + name = + Concrete_ident.of_def_id ~value:false (assert_item_def_id ()); generics = c_generics generics; ty = c_ty item.span ty; } @@ -1543,7 +1537,7 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = mk @@ Fn { - name = Concrete_ident.of_def_id Value (assert_item_def_id ()); + name = Concrete_ident.of_def_id ~value:true (assert_item_def_id ()); generics = c_generics generics; body = c_body body; params = c_fn_params item.span params; @@ -1553,18 +1547,17 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = let generics = c_generics generics in let is_struct = match item.kind with Struct _ -> true | _ -> false in let def_id = assert_item_def_id () in - let name = Concrete_ident.of_def_id Type def_id in + let name = Concrete_ident.of_def_id ~value:false def_id in mk @@ Type { name; generics; variants = []; is_struct } | Enum (variants, generics, repr) -> let def_id = assert_item_def_id () in let generics = c_generics generics in let is_struct = false in - let kind = Concrete_ident.Kind.Constructor { is_struct } in let discs = (* Each variant might introduce a anonymous constant defining its discriminant integer *) List.filter_map ~f:(fun v -> v.disr_expr) variants |> List.map ~f:(fun Types.{ def_id; body; _ } -> - let name = Concrete_ident.of_def_id kind def_id in + let name = Concrete_ident.of_def_id ~value:true def_id in let generics = { params = []; constraints = [] } in let body = c_expr body in { @@ -1589,13 +1582,13 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = [%matches? (Struct { fields = _ :: _; _ } : Types.variant_data)] data in - let name = Concrete_ident.of_def_id kind variant_id in + let name = Concrete_ident.of_def_id ~value:true variant_id in let arguments = match data with | Tuple (fields, _, _) | Struct { fields; _ } -> List.map ~f:(fun { def_id = id; ty; span; attributes; _ } -> - ( Concrete_ident.of_def_id Field id, + ( Concrete_ident.of_def_id ~value:true id, c_ty span ty, c_attrs attributes )) fields @@ -1605,7 +1598,7 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = ({ name; arguments; is_record; attrs }, original)) variants in - let name = Concrete_ident.of_def_id Type def_id in + let name = Concrete_ident.of_def_id ~value:true def_id in let cast_fun = cast_of_enum name generics (c_ty item.span repr.typ) item.span variants in @@ -1620,14 +1613,13 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = let is_struct = true in (* repeating the attributes of the item in the variant: TODO is that ok? *) let v = - let kind = Concrete_ident.Kind.Constructor { is_struct } in - let name = Concrete_ident.of_def_id kind def_id in - let name = Concrete_ident.Create.move_under name ~new_parent:name in + let name = Concrete_ident.of_def_id ~value:true def_id in + (* let name = Concrete_ident.Create.move_under name ~new_parent:name in *) let mk fields is_record = let arguments = List.map ~f:(fun Thir.{ def_id = id; ty; span; attributes; _ } -> - ( Concrete_ident.of_def_id Field id, + ( Concrete_ident.of_def_id ~value:true id, c_ty span ty, c_attrs attributes )) fields @@ -1640,13 +1632,13 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = | _ -> { name; arguments = []; is_record = false; attrs } in let variants = [ v ] in - let name = Concrete_ident.of_def_id Type def_id in + let name = Concrete_ident.of_def_id ~value:false def_id in mk @@ Type { name; generics; variants; is_struct } | MacroInvokation { macro_ident; argument; span } -> mk @@ IMacroInvokation { - macro = Concrete_ident.of_def_id Macro macro_ident; + macro = Concrete_ident.of_def_id ~value:false macro_ident; argument; span = Span.of_thir span; witness = W.macro; @@ -1657,7 +1649,9 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = ~f:(fun { attributes; _ } -> not (should_skip attributes)) items in - let name = Concrete_ident.of_def_id Trait (assert_item_def_id ()) in + let name = + Concrete_ident.of_def_id ~value:false (assert_item_def_id ()) + in let { params; constraints } = c_generics generics in let self = let id = Local_ident.mk_id Typ 0 (* todo *) in @@ -1679,7 +1673,9 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = in List.map ~f:(fun (item : Thir.impl_item) -> - let item_def_id = Concrete_ident.of_def_id Impl item.owner_id in + let item_def_id = + Concrete_ident.of_def_id ~value:false item.owner_id + in let attrs = c_item_attrs item.attributes in let sub_item_erased_by_user = erased_by_user attrs in let erased_by_type_only = @@ -1726,7 +1722,7 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = associated types \ (https://doc.rust-lang.org/reference/items/implementations.html#inherent-implementations)." in - let ident = Concrete_ident.of_def_id Value item.owner_id in + let ident = Concrete_ident.of_def_id ~value:false item.owner_id in { span = Span.of_thir item.span; v; ident; attrs }) items | Impl @@ -1758,7 +1754,8 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = params = [ U.make_unit_param span ]; }; ii_ident = - Concrete_ident.of_name Value Rust_primitives__hax__dropped_body; + Concrete_ident.of_name ~value:false + Rust_primitives__hax__dropped_body; ii_attrs = []; }; ] @@ -1769,7 +1766,9 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = something. Otherwise we have to assume every backend will see traits and impls as records. See https://github.com/hacspec/hax/issues/271. *) - let ii_ident = Concrete_ident.of_def_id Field item.owner_id in + let ii_ident = + Concrete_ident.of_def_id ~value:false item.owner_id + in { ii_span = Span.of_thir item.span; ii_generics = c_generics item.generics; @@ -1807,7 +1806,7 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = generics = c_generics generics; self_ty = c_ty item.span self_ty; of_trait = - ( Concrete_ident.of_def_id Trait of_trait.def_id, + ( Concrete_ident.of_def_id ~value:false of_trait.def_id, List.map ~f:(c_generic_value item.span) of_trait.generic_args ); items; @@ -1836,21 +1835,23 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = (* ident is supposed to always be an actual item, thus here we need to cheat a bit *) (* TODO: is this DUMMY thing really needed? there's a `Use` segment (see #272) *) let def_id = item.owner_id in - let def_id : Types.def_id = - let value = - { - def_id.contents.value with - path = - def_id.contents.value.path - @ [ - Types. - { data = ValueNs "DUMMY"; disambiguator = MyInt64.of_int 0 }; - ]; - } - in - { contents = { def_id.contents with value } } - in - [ { span; v; ident = Concrete_ident.of_def_id Value def_id; attrs } ] + (* let def_id : Types.def_id = + let value = + { + def_id.contents.value with + path = + def_id.contents.value.path + @ [ + Types. + { data = ValueNs "DUMMY"; disambiguator = MyInt64.of_int 0 }; + ]; + } + in + { contents = { def_id.contents with value } } + in *) + [ + { span; v; ident = Concrete_ident.of_def_id ~value:false def_id; attrs }; + ] | Union _ -> unimplemented ~issue_id:998 [ item.span ] "Union types: not supported" | ExternCrate _ | Static _ | Macro _ | Mod _ | ForeignMod _ | GlobalAsm _ @@ -1859,7 +1860,7 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = let import_item ~type_only (item : Thir.item) : concrete_ident * (item list * Diagnostics.t list) = - let ident = Concrete_ident.of_def_id Value item.owner_id in + let ident = Concrete_ident.of_def_id ~value:false item.owner_id in let r, reports = let f = U.Mappers.rename_generic_constraints#visit_item diff --git a/engine/lib/phases/phase_cf_into_monads.ml b/engine/lib/phases/phase_cf_into_monads.ml index d5565c4fb..8683dbd1c 100644 --- a/engine/lib/phases/phase_cf_into_monads.ml +++ b/engine/lib/phases/phase_cf_into_monads.ml @@ -52,16 +52,21 @@ struct | None -> x.typ | Some (MResult err) -> let args = List.map ~f:(fun t -> B.GType t) [ x.typ; err ] in - let ident = Global_ident.of_name Type Core__result__Result in + let ident = + Global_ident.of_name ~value:false Core__result__Result + in TApp { ident; args } | Some MOption -> let args = List.map ~f:(fun t -> B.GType t) [ x.typ ] in - let ident = Global_ident.of_name Type Core__option__Option in + let ident = + Global_ident.of_name ~value:false Core__option__Option + in TApp { ident; args } | Some (MException return) -> let args = List.map ~f:(fun t -> B.GType t) [ return; x.typ ] in let ident = - Global_ident.of_name Type Core__ops__control_flow__ControlFlow + Global_ident.of_name ~value:false + Core__ops__control_flow__ControlFlow in TApp { ident; args } diff --git a/engine/lib/phases/phase_direct_and_mut.ml b/engine/lib/phases/phase_direct_and_mut.ml index c0b557834..bcff1fa29 100644 --- a/engine/lib/phases/phase_direct_and_mut.ml +++ b/engine/lib/phases/phase_direct_and_mut.ml @@ -68,7 +68,8 @@ struct if hax_core_extraction then TApp { - ident = Global_ident.of_name Type Rust_primitives__hax__MutRef; + ident = + Global_ident.of_name ~value:false Rust_primitives__hax__MutRef; args = [ GType (dty span typ) ]; } else Error.raise { kind = UnallowedMutRef; span } diff --git a/engine/lib/phases/phase_drop_match_guards.ml b/engine/lib/phases/phase_drop_match_guards.ml index f54e61a53..14970879a 100644 --- a/engine/lib/phases/phase_drop_match_guards.ml +++ b/engine/lib/phases/phase_drop_match_guards.ml @@ -106,7 +106,7 @@ module%inlined_contents Make (F : Features.T) = struct let opt_result_typ : B.ty = TApp { - ident = Global_ident.of_name Type Core__option__Option; + ident = Global_ident.of_name ~value:false Core__option__Option; args = [ GType result_typ ]; } in @@ -128,8 +128,7 @@ module%inlined_contents Make (F : Features.T) = struct | None -> (Core__option__Option__None, []) in MS.pat_PConstruct - ~constructor: - (Global_ident.of_name (Constructor { is_struct = false }) name) + ~constructor:(Global_ident.of_name ~value:true name) ~fields ~is_record:false ~is_struct:false ~typ:opt_result_typ in diff --git a/engine/lib/phases/phase_drop_return_break_continue.ml b/engine/lib/phases/phase_drop_return_break_continue.ml index ad0e6d201..00f3e3a34 100644 --- a/engine/lib/phases/phase_drop_return_break_continue.ml +++ b/engine/lib/phases/phase_drop_return_break_continue.ml @@ -152,7 +152,7 @@ module%inlined_contents Make (F : Features.T) = struct match body.typ with | TApp { ident; args = [ GType _; GType continue_type ] } when Ast.Global_ident.equal ident - (Ast.Global_ident.of_name Type + (Ast.Global_ident.of_name ~value:false Core__ops__control_flow__ControlFlow) -> continue_type | _ -> body.typ diff --git a/engine/lib/phases/phase_functionalize_loops.ml b/engine/lib/phases/phase_functionalize_loops.ml index 3855c1e12..a583cbc6e 100644 --- a/engine/lib/phases/phase_functionalize_loops.ml +++ b/engine/lib/phases/phase_functionalize_loops.ml @@ -211,7 +211,7 @@ struct let pat = dpat pat in let fn : B.expr = UB.make_closure [ bpat; pat ] body body.span in let cf = Option.map ~f:fst control_flow in - let f, kind, args = + let f, args = match as_iterator it |> Option.bind ~f:(fn_args_of_iterator cf) with | Some (f, args, typ) -> (* TODO what happens if there is control flow? *) @@ -223,7 +223,7 @@ struct let pat, invariant = Option.value ~default invariant in UB.make_closure [ bpat; pat ] invariant invariant.span in - (f, Concrete_ident.Kind.Value, args @ [ invariant; init; fn ]) + (f, args @ [ invariant; init; fn ]) | None -> let fold : Concrete_ident.name = match cf with @@ -232,9 +232,9 @@ struct | Some BreakOnly -> Rust_primitives__hax__folds__fold_cf | None -> Core__iter__traits__iterator__Iterator__fold in - (fold, AssociatedItem Value, [ it; init; fn ]) + (fold, [ it; init; fn ]) in - UB.call ~kind f args span (dty span expr.typ) + UB.call f args span (dty span expr.typ) | Loop { body; @@ -276,8 +276,8 @@ struct | Some (BreakOnly, _) -> Rust_primitives__hax__while_loop_cf | None -> Rust_primitives__hax__while_loop in - UB.call ~kind:(AssociatedItem Value) fold_operator - [ condition; init; body ] span (dty span expr.typ) + UB.call fold_operator [ condition; init; body ] span + (dty span expr.typ) | Loop { state = None; _ } -> Error.unimplemented ~issue_id:405 ~details:"Loop without mutation" span diff --git a/engine/lib/phases/phase_reconstruct_asserts.ml b/engine/lib/phases/phase_reconstruct_asserts.ml index 0dfacd364..fe899c8b0 100644 --- a/engine/lib/phases/phase_reconstruct_asserts.ml +++ b/engine/lib/phases/phase_reconstruct_asserts.ml @@ -72,7 +72,7 @@ module Make (F : Features.T) = { e = GlobalVar - (Ast.Global_ident.of_name Value + (Ast.Global_ident.of_name ~value:true Core__ops__bit__Not__not); span = cond_expr.span; typ = TArrow ([ TBool ], TBool); @@ -94,7 +94,8 @@ module Make (F : Features.T) = { e = GlobalVar - (Ast.Global_ident.of_name Value Hax_lib__assert); + (Ast.Global_ident.of_name ~value:true + Hax_lib__assert); span = e.span; typ = TArrow diff --git a/engine/lib/phases/phase_reconstruct_question_marks.ml b/engine/lib/phases/phase_reconstruct_question_marks.ml index d25841b05..2487644f4 100644 --- a/engine/lib/phases/phase_reconstruct_question_marks.ml +++ b/engine/lib/phases/phase_reconstruct_question_marks.ml @@ -71,7 +71,7 @@ module%inlined_contents Make (FA : Features.T) = struct (** Construct [Result] *) let make_result_type (success : ty) (error : ty) : ty = - let ident = Global_ident.of_name Type Core__result__Result in + let ident = Global_ident.of_name ~value:false Core__result__Result in TApp { ident; args = [ GType success; GType error ] } (** Retype a [Err::<_, E>(x)] literal, as [Err::(x)] *) @@ -92,8 +92,7 @@ module%inlined_contents Make (FA : Features.T) = struct else let from_typ = TArrow ([ error_src ], error_dest) in let from = - UA.call ~kind:(AssociatedItem Value) ~impl Core__convert__From__from - [] e.span from_typ + UA.call ~impl Core__convert__From__from [] e.span from_typ in let call = UA.call Core__result__Impl__map_err [ e; from ] e.span diff --git a/engine/lib/phases/phase_simplify_question_marks.ml b/engine/lib/phases/phase_simplify_question_marks.ml index 22233e33a..b77977519 100644 --- a/engine/lib/phases/phase_simplify_question_marks.ml +++ b/engine/lib/phases/phase_simplify_question_marks.ml @@ -71,7 +71,7 @@ module%inlined_contents Make (FA : Features.T) = struct (** Construct [Result] *) let make_result_type (success : ty) (error : ty) : ty = - let ident = Global_ident.of_name Type Core__result__Result in + let ident = Global_ident.of_name ~value:false Core__result__Result in TApp { ident; args = [ GType success; GType error ] } (** Retype a [Err::<_, E>(x)] literal, as [Err::(x)] *) @@ -89,8 +89,8 @@ module%inlined_contents Make (FA : Features.T) = struct let from_typ = TArrow ([ error_src ], error_dest) in let impl_generic_args = [ GType error_dest; GType error_src ] in Some - (UA.call ~impl_generic_args ~kind:(AssociatedItem Value) ~impl - Core__convert__From__from [ e ] e.span from_typ) + (UA.call ~impl_generic_args ~impl Core__convert__From__from [ e ] + e.span from_typ) (** [map_err e error_dest impl] creates the expression [e.map_err(from)] with the proper types and impl @@ -99,10 +99,7 @@ module%inlined_contents Make (FA : Features.T) = struct let* success, error_src = expect_result_type e.typ in let* impl = expect_residual_impl_result impl in let from_typ = TArrow ([ error_src ], error_dest) in - let from = - UA.call ~kind:(AssociatedItem Value) ~impl Core__convert__From__from - [] e.span from_typ - in + let from = UA.call ~impl Core__convert__From__from [] e.span from_typ in let call = UA.call Core__result__Impl__map_err [ e; from ] e.span (make_result_type success error_dest) @@ -112,13 +109,11 @@ module%inlined_contents Make (FA : Features.T) = struct let mk_pconstruct ~is_struct ~is_record ~span ~typ (constructor : Concrete_ident_generated.t) (fields : (Concrete_ident_generated.t * pat) list) = - let constructor = - Global_ident.of_name (Constructor { is_struct }) constructor - in + let constructor = Global_ident.of_name ~value:true constructor in let fields = List.map ~f:(fun (field, pat) -> - let field = Global_ident.of_name Field field in + let field = Global_ident.of_name ~value:true field in { field; pat }) fields in diff --git a/engine/lib/phases/phase_specialize.ml b/engine/lib/phases/phase_specialize.ml index 5b5f0a6b2..5916792c2 100644 --- a/engine/lib/phases/phase_specialize.ml +++ b/engine/lib/phases/phase_specialize.ml @@ -132,7 +132,7 @@ module Make (F : Features.T) = in match matching with | [ { fn_replace; _ } ] -> - let f = Ast.Global_ident.of_name Value fn_replace in + let f = Ast.Global_ident.of_name ~value:true fn_replace in let f = { f' with e = GlobalVar f } in { e with diff --git a/engine/lib/phases/phase_traits_specs.ml b/engine/lib/phases/phase_traits_specs.ml index 6020266a4..f6159bd47 100644 --- a/engine/lib/phases/phase_traits_specs.ml +++ b/engine/lib/phases/phase_traits_specs.ml @@ -17,8 +17,7 @@ module Make (F : Features.T) = let ctx = Diagnostics.Context.Phase phase_id end) - let mk_name ident (kind : string) = - Concrete_ident.Create.map_last ~f:(fun s -> s ^ "_" ^ kind) ident + let mk_name ident kind = Concrete_ident.with_suffix kind ident module Attrs = Attr_payloads.Make (F) (Error) @@ -52,11 +51,11 @@ module Make (F : Features.T) = | TIFn (TArrow (inputs, output)) -> [ { - (mk Types.Requires "pre") with + (mk Types.Requires `Pre) with ti_v = TIFn (TArrow (inputs, TBool)); }; { - (mk Types.Ensures "post") with + (mk Types.Ensures `Post) with ti_v = TIFn (TArrow (inputs @ [ output ], TBool)); }; ] @@ -109,7 +108,7 @@ module Make (F : Features.T) = | Some (_, params, body) -> (params, body) | None -> (params, default) in - { (mk "pre") with ii_v = IIFn { body; params } }); + { (mk `Pre) with ii_v = IIFn { body; params } }); (let params, body = match Attrs.associated_fn Ensures item.ii_attrs with | Some (_, params, body) -> (params, body) @@ -136,7 +135,7 @@ module Make (F : Features.T) = in (params @ [ out ], default) in - { (mk "post") with ii_v = IIFn { body; params } }); + { (mk `Post) with ii_v = IIFn { body; params } }); ] | IIType _ -> [] in diff --git a/engine/lib/print_rust.ml b/engine/lib/print_rust.ml index a0ad06b81..858782a2a 100644 --- a/engine/lib/print_rust.ml +++ b/engine/lib/print_rust.ml @@ -2,11 +2,15 @@ open! Prelude open Ast open Ast.Full -module Concrete_ident_view = Concrete_ident.MakeViewAPI (struct - include Concrete_ident.DefaultNamePolicy +module View = struct + include Concrete_ident.MakeRenderAPI (struct + include Concrete_ident.DefaultNamePolicy - let index_field_transform field = "_" ^ field -end) + let anonymous_field_transform field = "_" ^ field + end) + + let to_definition_name id = (render id).name +end module AnnotatedString = struct module T = struct @@ -90,7 +94,7 @@ module Raw = struct let ( ! ) s = pure span (prefix ^ s) in match e with | `Concrete c -> - !(let s = Concrete_ident_view.show c in + !(let s = View.show c in if String.equal "_" s then "_anon" else s) | `Primitive p -> pprimitive_ident span p | `TupleType n -> ![%string "tuple%{Int.to_string n}"] @@ -126,7 +130,7 @@ module Raw = struct let rec last_of_global_ident (g : global_ident) span = match g with - | `Concrete c -> Concrete_ident_view.to_definition_name c + | `Concrete c -> View.to_definition_name c | `Projector c -> last_of_global_ident (c :> global_ident) span | _ -> Diagnostics.report @@ -169,7 +173,7 @@ module Raw = struct in !"arrow!(" & arrow & !")" | TAssociatedType _ -> !"proj_asso_type!()" - | TOpaque ident -> !(Concrete_ident_view.show ident) + | TOpaque ident -> !(View.show ident) | TDyn { goals; _ } -> let goals = concat ~sep:!" + " (List.map ~f:(pdyn_trait_goal span) goals) @@ -181,7 +185,7 @@ module Raw = struct let args = List.map ~f:(pgeneric_value span) non_self_args |> concat ~sep:!", " in - !(Concrete_ident_view.show trait) + !(View.show trait) & if List.is_empty args then empty else !"<" & args & !">" and pgeneric_value span (e : generic_value) : AnnotatedString.t = @@ -416,7 +420,7 @@ module Raw = struct let ptrait_goal span { trait; args } = let ( ! ) = pure span in let args = List.map ~f:(pgeneric_value span) args |> concat ~sep:!", " in - !(Concrete_ident_view.show trait) + !(View.show trait) & if List.is_empty args then empty else !"<" & args & !">" let pprojection_predicate span (pp : projection_predicate) = @@ -426,9 +430,9 @@ module Raw = struct |> Option.map ~f:(pty span) |> Option.value ~default:!"unknown_self" & !" :" - & !(Concrete_ident_view.show pp.impl.goal.trait) + & !(View.show pp.impl.goal.trait) & !"<" - & !(Concrete_ident_view.to_definition_name pp.assoc_item) + & !(View.to_definition_name pp.assoc_item) & !" = " & pty span pp.typ & !">" let pgeneric_constraint span (p : generic_constraint) = @@ -451,9 +455,7 @@ module Raw = struct !"{" & concat ~sep:!"," (List.map arguments ~f:(fun (id, ty, attrs) -> - pattrs attrs - & !(Concrete_ident_view.to_definition_name id) - & !":" & pty span ty)) + pattrs attrs & !(View.to_definition_name id) & !":" & pty span ty)) & !"}" else !"(" @@ -465,7 +467,7 @@ module Raw = struct let pvariant span (variant : variant) = let ( ! ) = pure span in pattrs variant.attrs - & !(Concrete_ident_view.to_definition_name variant.name) + & !(View.to_definition_name variant.name) & pvariant_body span variant let pvariants span variants = @@ -485,7 +487,7 @@ module Raw = struct let ( ! ) = pure ti.ti_span in let generics = pgeneric_params ti.ti_generics.params in let bounds = pgeneric_constraints ti.ti_span ti.ti_generics.constraints in - let ident = !(Concrete_ident_view.to_definition_name ti.ti_ident) in + let ident = !(View.to_definition_name ti.ti_ident) in pattrs ti.ti_attrs & match ti.ti_v with @@ -518,7 +520,7 @@ module Raw = struct let ( ! ) = pure span in let generics = pgeneric_params ii.ii_generics.params in let bounds = pgeneric_constraints span ii.ii_generics.constraints in - let ident = !(Concrete_ident_view.to_definition_name ii.ii_ident) in + let ident = !(View.to_definition_name ii.ii_ident) in pattrs ii.ii_attrs & match ii.ii_v with @@ -537,27 +539,27 @@ module Raw = struct | Fn { name; body; generics; params; safety } -> let return_type = pty e.span body.typ in (match safety with Safe -> !"fn " | Unsafe _ -> !"unsafe fn ") - & !(Concrete_ident_view.to_definition_name name) + & !(View.to_definition_name name) & pgeneric_params generics.params & pparams e.span params & !" -> " & return_type & pgeneric_constraints e.span generics.constraints & !"{" & pexpr body & !"}" | TyAlias { name; generics; ty } -> !"type " - & !(Concrete_ident_view.to_definition_name name) + & !(View.to_definition_name name) & pgeneric_params generics.params & pgeneric_constraints e.span generics.constraints & !"=" & pty e.span ty & !";" | Type { name; generics; variants = [ variant ]; is_struct = true } -> !"struct " - & !(Concrete_ident_view.to_definition_name name) + & !(View.to_definition_name name) & pgeneric_params generics.params & pgeneric_constraints e.span generics.constraints & pvariant_body e.span variant & if variant.is_record then !"" else !";" | Type { name; generics; variants; _ } -> !"enum " - & !(Concrete_ident_view.to_definition_name name) + & !(View.to_definition_name name) & pgeneric_params generics.params & pgeneric_constraints e.span generics.constraints & @@ -568,7 +570,7 @@ module Raw = struct match safety with Safe -> !"" | Unsafe _ -> !"unsafe " in safety & !"trait " - & !(Concrete_ident_view.to_definition_name name) + & !(View.to_definition_name name) & pgeneric_params generics.params & pgeneric_constraints e.span generics.constraints & !"{" diff --git a/engine/lib/utils.ml b/engine/lib/utils.ml index c1e66f6dc..6ae966d42 100644 --- a/engine/lib/utils.ml +++ b/engine/lib/utils.ml @@ -25,6 +25,10 @@ let apply f x = f x let ( let* ) x f = Option.bind ~f x let some_if_true = function true -> Some () | _ -> None +let expect_singleton : 'a. 'a list -> 'a option = function + | [ x ] -> Some x + | _ -> None + (** [let*? () = guard in body] acts as a guard: if [guard] holds, then [body] is executed, otherwise [None] is returned. *) let ( let*? ) (type a) (x : bool) (f : unit -> a option) = @@ -51,6 +55,15 @@ let split_list ~equal ~needle (subject : 'a list) : 'a list list = in h subject +(** Map over a list with a option-returning function. Returns `Some` iff every calls to `f` returned `Some`. *) +let rec maybe_map ~(f : 'a -> 'b option) (l : 'a list) : 'b list option = + match l with + | hd :: tl -> + let* hd = f hd in + let* tl = maybe_map ~f tl in + Some (hd :: tl) + | [] -> Some [] + let first_letter s = String.prefix s 1 let is_uppercase s = String.equal s (String.uppercase s) let is_lowercase s = String.equal s (String.lowercase s) @@ -115,4 +128,22 @@ module List = struct let zip_opt : 'a 'b. 'a list -> 'b list -> ('a * 'b) list option = fun x y -> match zip x y with Ok result -> Some result | Unequal_lengths -> None + + let longest_prefix (type t) ~(eq : t -> t -> bool) (l : t list list) : t list + = + match l with + | [] -> [] + | hd :: tl -> + let tl = ref tl in + let f x = + let exception Stop in + try + tl := + List.map !tl ~f:(function + | y :: tl when eq x y -> tl + | _ -> raise Stop); + true + with Stop -> false + in + List.take_while ~f hd end diff --git a/engine/names/src/lib.rs b/engine/names/src/lib.rs index 9df5efea9..af1ea0919 100644 --- a/engine/names/src/lib.rs +++ b/engine/names/src/lib.rs @@ -146,9 +146,8 @@ macro_rules! impl_arith { } } -impl_arith!(u128); -// impl_arith!(u8, u16, u32, u64, u128, usize); -// impl_arith!(i8, i16, i32, i64, i128, isize); +impl_arith!(u8, u16, u32, u64, u128, usize); +impl_arith!(i8, i16, i32, i64, i128, isize); fn offset() {} diff --git a/engine/utils/ocaml_of_json_schema/ocaml_of_json_schema.js b/engine/utils/ocaml_of_json_schema/ocaml_of_json_schema.js index 92825b158..6decb4220 100644 --- a/engine/utils/ocaml_of_json_schema/ocaml_of_json_schema.js +++ b/engine/utils/ocaml_of_json_schema/ocaml_of_json_schema.js @@ -360,8 +360,12 @@ let is_type = { // return output; // }; -let export_record = (fields, path) => { - let record_expression = fields.map(([field, type], i) => { +let export_record = (fields, path, name) => { + let record_expression = fields.map(([field, type, _doc], i) => { + if (field == 'index' && name == 'def_id_contents') { + // This is a hack to always parse Rust DefId indexes to `(0, 0)` + return 'index = Base.Int64.(zero, zero)'; + } let p = [...path, 'field_' + field]; let sub = mk_match('x', ocaml_arms_of_type_expr(type, p), p); let match = `match List.assoc_opt "${field}" l with Option.Some x -> begin ${sub} end | Option.None -> raise (MissingField {field = "${field}"; fields = l})`; @@ -402,7 +406,7 @@ let exporters = { ]; return ({ record: () => { - let [pat, expr] = export_record(Object.entries(payload), ['rec-variant_' + variant + '_' + variant_name]); + let [pat, expr] = export_record(Object.entries(payload), ['rec-variant_' + variant + '_' + variant_name], name); return wrap([[pat, variant + ' ' + expr]]); }, expr: () => wrap(ocaml_arms_of_type_expr(payload, ['expr-variant(PA):' + name + ':' + variant + ':' + variant_name]), variant + ' '), @@ -456,7 +460,7 @@ let exporters = { ([name, prop]) => [name, is_type.expr(prop), prop.description] ); - let [pat, expr] = export_record(fields, ['struct_' + name]); + let [pat, expr] = export_record(fields, ['struct_' + name], name); return { type: `{ ${fields.map(([fname, type, doc]) => `${fieldNameOf(fname)} : ${ocaml_of_type_expr(type, ['struct_' + fname + '_' + name])}${mkdoc(doc)}`).join(';\n')} }`, @@ -646,23 +650,23 @@ let table_id_node_of_yojson (type t) (name: string) (encode: t -> map_types) (de ).join('\nand ')); impl += ` and node_for__ty_kind_of_yojson (o: Yojson.Safe.t): node_for__ty_kind = - let (value, id) = + let (value, _id) = table_id_node_of_yojson "TyKind" (fun value -> \`TyKind value) (function | \`TyKind value -> Some value | _ -> None) ty_kind_of_yojson o in - {value; id} + {value; id = Base.Int64.zero} and node_for__def_id_contents_of_yojson (o: Yojson.Safe.t): node_for__def_id_contents = - let (value, id) = + let (value, _id) = table_id_node_of_yojson "DefIdContents" (fun value -> \`DefIdContents value) (function | \`DefIdContents value -> Some value | _ -> None) def_id_contents_of_yojson o in - {value; id} + {value; id = Base.Int64.zero} `; impl += (''); impl += ('let rec ' + items.map(({ name, type, parse, to_json }) => diff --git a/flake.nix b/flake.nix index 2bd83b20f..7f816698a 100644 --- a/flake.nix +++ b/flake.nix @@ -199,8 +199,9 @@ pkgs.rust-analyzer pkgs.toml2json rustfmt - rustc utils + + pkgs.rustup ]; LIBCLANG_PATH = "${pkgs.llvmPackages.libclang.lib}/lib"; in { From 79ab4b8bd28be98ffa4cda7b8562ac285f90d241 Mon Sep 17 00:00:00 2001 From: Lucas Franceschino Date: Mon, 27 Jan 2025 15:05:58 +0100 Subject: [PATCH 06/21] refactor: make inline lib require no new concrete identifiers --- .../phases/phase_transform_hax_lib_inline.ml | 132 +++++++++--------- 1 file changed, 66 insertions(+), 66 deletions(-) diff --git a/engine/lib/phases/phase_transform_hax_lib_inline.ml b/engine/lib/phases/phase_transform_hax_lib_inline.ml index 5e0fcf65a..3ae769b32 100644 --- a/engine/lib/phases/phase_transform_hax_lib_inline.ml +++ b/engine/lib/phases/phase_transform_hax_lib_inline.ml @@ -161,73 +161,73 @@ module%inlined_contents Make (F : Features.T) = struct [%%inline_defs "Item.*" - ditems] let ditems items = - let (module Attrs) = Attrs.with_items items in - let f (item : A.item) = - let before, after = - let map_fst = List.map ~f:fst in - try - let replace = Attrs.late_skip item.attrs in - Attrs.associated_items Attr_payloads.AssocRole.ItemQuote item.attrs - |> List.map ~f:(fun assoc_item -> - let e : A.expr = - assoc_item |> Attrs.expect_fn |> Attrs.expect_expr - in - let quote = - UA.Expect.block e |> Option.value ~default:e - |> quote_of_expr - |> Option.value_or_thunk ~default:(fun _ -> - Error.assertion_failure assoc_item.span - @@ "Malformed `Quote` item: `quote_of_expr` \ - failed. Expression was:\n" - (* ^ (UA.LiftToFullAst.expr e |> Print_rust.pexpr_str) *) - ^ [%show: A.expr] e) - in - let span = e.span in - let position, attr = - Attrs.find_unique_attr assoc_item.attrs ~f:(function - | ItemQuote q as attr -> Some (q.position, attr) - | _ -> None) - |> Option.value_or_thunk ~default:(fun _ -> - Error.assertion_failure assoc_item.span - "Malformed `Quote` item: could not find a \ - ItemQuote payload") - in - let v : B.item' = - let origin : item_quote_origin = - { - item_kind = UA.kind_of_item item; - item_ident = item.ident; - position = - (if replace then `Replace - else - match position with - | After -> `After - | Before -> `Before); - } - in - Quote { quote; origin } - in - let attrs = [ Attr_payloads.to_attr attr assoc_item.span ] in - counter := !counter + 1; - ( B. - { - v; - span; - ident = - (* TODO: Replace with a proper unique ident. *) - Concrete_ident.Create.replace_last item.ident - ("__hax_quote__" ^ Int.to_string !counter); - attrs; - }, - position )) - |> List.partition_tf ~f:(snd >> [%matches? Types.Before]) - |> map_fst *** map_fst - with Diagnostics.SpanFreeError.Exn (Data (context, kind)) -> - let error = Diagnostics.pretty_print_context_kind context kind in - let msg = error in - ([ B.make_hax_error_item item.span item.ident msg ], []) + let find_parent_item : + Attr_payloads.UId.t -> (Attr_payloads.AssocRole.t * A.item) option = + List.concat_map + ~f:(fun (item : A.item) -> + Attrs.raw_associated_item item.attrs + |> List.map ~f:(fun (role, child_uid) -> (child_uid, (role, item)))) + items + |> Map.of_alist_exn (module Attr_payloads.UId) + |> Map.find + in + (* If [item] can be interpreted as a quote, return a `Quote` item *) + let item_as_quote (item : A.item) = + let* body = + match item.v with + | Fn { body = { e = Block { e; _ }; _ }; _ } -> Some e + | _ -> None + in + let* uid = Attrs.uid item.attrs in + let* role, _ = find_parent_item uid in + let*? () = [%equal: Attr_payloads.AssocRole.t] ItemQuote role in + let replace = Attrs.late_skip item.attrs in + let* role = + Attrs.find_unique_attr + ~f:(function ItemQuote q -> Some q | _ -> None) + item.attrs + in + let origin : item_quote_origin = + { + item_kind = UA.kind_of_item item; + item_ident = item.ident; + position = + (if replace then `Replace + else + match role.position with After -> `After | Before -> `Before); + } in - before @ ditem item @ after + let quote = + quote_of_expr body + |> Option.value_or_thunk ~default:(fun _ -> + Error.assertion_failure item.span + @@ "Malformed `Quote` item: `quote_of_expr` failed. \ + Expression was:\n" + ^ [%show: A.expr] body) + in + let attrs = + let is_late_skip = + [%matches? Types.ItemStatus (Included { late_skip = true })] + in + item.attrs |> Attr_payloads.payloads + |> List.filter ~f:(fst >> is_late_skip >> not) + |> List.map ~f:(fun (v, span) -> Attr_payloads.to_attr v span) + in + let A.{ span; ident; _ } = item in + Some B.{ v = Quote { quote; origin }; span; ident; attrs } + in + (* Wraps [item_as_quote] to handle exns and fallback to the original item if the item is not a quote. *) + let f i = + try + item_as_quote i + |> Option.map ~f:(fun i -> [ i ]) + |> Option.value ~default:(ditem i) + with Diagnostics.SpanFreeError.Exn (Data (context, kind)) -> + let error = Diagnostics.pretty_print_context_kind context kind in + let cast_item : A.item -> Ast.Full.item = Stdlib.Obj.magic in + let ast = cast_item i |> Print_rust.pitem_str in + let msg = error ^ "\nLast available AST for this item:\n\n" ^ ast in + [ B.make_hax_error_item i.span i.ident msg ] in List.concat_map ~f items end From 3ffefff31100c194256a2e2831d7644f06ae277d Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Mon, 27 Jan 2025 16:03:09 +0100 Subject: [PATCH 07/21] Remove dummy method in opaque trait impls. --- engine/lib/import_thir.ml | 19 +------------------ 1 file changed, 1 insertion(+), 18 deletions(-) diff --git a/engine/lib/import_thir.ml b/engine/lib/import_thir.ml index ef3bfa341..df9ff0aa5 100644 --- a/engine/lib/import_thir.ml +++ b/engine/lib/import_thir.ml @@ -1741,24 +1741,7 @@ and c_item_unwrapped ~ident ~type_only (item : Thir.item) : item list = items in let items = - if erased then - [ - (* Dummy associated item *) - { - ii_span = Span.of_thir item.span; - ii_generics = { params = []; constraints = [] }; - ii_v = - IIFn - { - body = U.unit_expr span; - params = [ U.make_unit_param span ]; - }; - ii_ident = - Concrete_ident.of_name ~value:false - Rust_primitives__hax__dropped_body; - ii_attrs = []; - }; - ] + if erased then [] else List.map ~f:(fun (item : Thir.impl_item) -> From c6d90234ea870d99d85296e07f267228be5c1da3 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Mon, 27 Jan 2025 16:04:02 +0100 Subject: [PATCH 08/21] Keep renamings for sub-idents that are NOT anonymous. --- engine/lib/dependencies.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/engine/lib/dependencies.ml b/engine/lib/dependencies.ml index 258f91daf..6a9bae9be 100644 --- a/engine/lib/dependencies.ml +++ b/engine/lib/dependencies.ml @@ -26,7 +26,7 @@ module Make (F : Features.T) = struct ~f:(fun variant -> let fields = List.map ~f:fst3 variant.arguments - |> List.filter ~f:is_field_anonymous + |> List.filter ~f:(not << is_field_anonymous) in variant.name :: fields) From fb1d5914a1732214ad219d8debd69921f6bd7686 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Tue, 28 Jan 2025 16:20:47 +0100 Subject: [PATCH 09/21] Fix clash of names between enums and structs in bundles. --- engine/lib/concrete_ident/concrete_ident.ml | 64 +++++++++++---------- 1 file changed, 33 insertions(+), 31 deletions(-) diff --git a/engine/lib/concrete_ident/concrete_ident.ml b/engine/lib/concrete_ident/concrete_ident.ml index 43ddba63b..080411ce1 100644 --- a/engine/lib/concrete_ident/concrete_ident.ml +++ b/engine/lib/concrete_ident/concrete_ident.ml @@ -212,11 +212,7 @@ module MakeToString (R : VIEW_RENDERER) = struct To generate a fresh name, we use the set of rendered names. *) let per_module : - ( string list, - (View.RelPath.t, t) Hashtbl.t - * string Hash_set.t - * (t, string) Hashtbl.t ) - Hashtbl.t = + (string list, string Hash_set.t * (t, string) Hashtbl.t) Hashtbl.t = Hashtbl.create (module struct type t = string list [@@deriving hash, compare, sexp, eq] @@ -226,12 +222,10 @@ module MakeToString (R : VIEW_RENDERER) = struct let Concrete_ident_view.{ mod_path; rel_path } = to_view i in let path = List.map ~f:R.render_module mod_path in (* Retrieve the various maps. *) - let rel_path_map, name_set, memo = + let name_set, memo = Hashtbl.find_or_add per_module ~default:(fun _ -> - ( Hashtbl.create (module View.RelPath), - Hash_set.create (module String), - Hashtbl.create (module T) )) + (Hash_set.create (module String), Hashtbl.create (module T))) path in (* If we rendered [i] already in the past, just use that. *) @@ -262,31 +256,39 @@ module MakeToString (R : VIEW_RENDERER) = struct escape_sep name else name in + let is_assoc (rel_path : View.RelPath.t) : bool = + match List.last rel_path with + | Some (`AssociatedItem _) -> true + | _ -> false + in let name = - match Hashtbl.find rel_path_map rel_path with - | Some _ when moved_into_fresh_ns -> - let path : View.ModPath.t = - (View.of_def_id i.def_id).mod_path - in - let path = List.map ~f:R.render_module path in - (* Generates the list of all prefixes of reversed `path` *) - List.folding_map ~init:[] (List.rev path) ~f:(fun acc chunk -> - let acc = chunk :: acc in - (acc, acc)) - (* We want to try small prefixes first *) - |> List.map ~f:List.rev - (* We generate a fake path with module ancestors *) - |> List.map ~f:(fun path -> - name ^ "__from__" - ^ String.concat ~sep:"__" - path (* This might shadow, we should escape *)) - (* Find the shortest name that doesn't exist already *) - |> List.find ~f:(Hash_set.mem name_set >> not) - |> Option.value_exn - | _ -> name + if + Hash_set.mem name_set name && moved_into_fresh_ns + && (not << is_assoc) rel_path + (* If this rel_path already exists in a fresh namespace, + then we have a duplicate and we should disambiguate. + Unless for associated items which correspond to trait + methods which may be repeated (with their implementations). *) + then + let path : View.ModPath.t = (View.of_def_id i.def_id).mod_path in + let path = List.map ~f:R.render_module path in + (* Generates the list of all prefixes of reversed `path` *) + List.folding_map ~init:[] (List.rev path) ~f:(fun acc chunk -> + let acc = chunk :: acc in + (acc, acc)) + (* We want to try small prefixes first *) + |> List.map ~f:List.rev + (* We generate a fake path with module ancestors *) + |> List.map ~f:(fun path -> + name ^ "__from__" + ^ String.concat ~sep:"__" + path (* This might shadow, we should escape *)) + (* Find the shortest name that doesn't exist already *) + |> List.find ~f:(Hash_set.mem name_set >> not) + |> Option.value_exn + else name in (* Update the maps and hashtables *) - let _ = Hashtbl.add rel_path_map ~key:rel_path ~data:i in let _ = Hash_set.add name_set name in let _ = Hashtbl.add memo ~key:i ~data:name in name From 7ed7906ecf345790d1cb262d180e011025958e9b Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 10:23:01 +0100 Subject: [PATCH 10/21] Avoid importing constructors from bundles when they don't exist. --- engine/lib/dependencies.ml | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/engine/lib/dependencies.ml b/engine/lib/dependencies.ml index 6a9bae9be..8ea3f7eb2 100644 --- a/engine/lib/dependencies.ml +++ b/engine/lib/dependencies.ml @@ -513,14 +513,21 @@ module Make (F : Features.T) = struct (idents_of item)) in let aliases = - List.map renamings ~f:(fun (origin_item, (from_id, to_id)) -> + List.filter_map renamings ~f:(fun (origin_item, (from_id, to_id)) -> let attrs = List.filter ~f:(fun att -> Attrs.late_skip [ att ]) origin_item.attrs in let v = Alias { name = from_id; item = to_id } in - { attrs; span = origin_item.span; ident = from_id; v }) + match origin_item.v with + (* We don't want to aliases for constructors of structs with named fields because + they can't be imported in F*. Ideally this should be handled by the backend. *) + | Type { variants; is_struct = true; _ } + when List.for_all variants ~f:(fun variant -> variant.is_record) + && Concrete_ident.is_constructor from_id -> + None + | _ -> Some { attrs; span = origin_item.span; ident = from_id; v }) in let rename = let renamings = List.map ~f:snd renamings in From b14f800f53cf9efa7a638988d58b5656214c5f01 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 10:24:04 +0100 Subject: [PATCH 11/21] Avoid disambiguating fields of the same struct. --- engine/lib/concrete_ident/concrete_ident.ml | 13 ++++++++----- engine/lib/concrete_ident/concrete_ident.mli | 2 ++ 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/engine/lib/concrete_ident/concrete_ident.ml b/engine/lib/concrete_ident/concrete_ident.ml index 080411ce1..64459c6e9 100644 --- a/engine/lib/concrete_ident/concrete_ident.ml +++ b/engine/lib/concrete_ident/concrete_ident.ml @@ -256,19 +256,20 @@ module MakeToString (R : VIEW_RENDERER) = struct escape_sep name else name in - let is_assoc (rel_path : View.RelPath.t) : bool = + let is_assoc_or_field (rel_path : View.RelPath.t) : bool = match List.last rel_path with - | Some (`AssociatedItem _) -> true + | Some (`AssociatedItem _ | `Field _) -> true | _ -> false in let name = if Hash_set.mem name_set name && moved_into_fresh_ns - && (not << is_assoc) rel_path + && (not << is_assoc_or_field) rel_path (* If this rel_path already exists in a fresh namespace, then we have a duplicate and we should disambiguate. Unless for associated items which correspond to trait - methods which may be repeated (with their implementations). *) + methods which may be repeated (with their implementations), + and for fields (which are repeated by accessors). *) then let path : View.ModPath.t = (View.of_def_id i.def_id).mod_path in let path = List.map ~f:R.render_module path in @@ -562,7 +563,7 @@ module MakeRenderAPI (NP : NAME_POLICY) : RENDER_API = struct | `Field ({ data; disambiguator }, _) when Option.is_some (Int.of_string_opt data) && Int64.equal disambiguator Int64.zero -> - UnsafeString (NP.anonymous_field_transform data) + TrustedString (NP.anonymous_field_transform data) (* Named fields *) | `Field (n, _) -> prefix "f" (dstr n) (* Anything function-like *) @@ -654,6 +655,8 @@ let map_path_strings ~(f : string -> string) (did : t) : t = in { def_id; moved = None; suffix = None } +let is_constructor (did : t) : bool = Explicit_def_id.is_constructor did.def_id + let matches_namespace (ns : Types.namespace) (did : t) : bool = let did = Explicit_def_id.to_def_id did.def_id in let path : string option list = diff --git a/engine/lib/concrete_ident/concrete_ident.mli b/engine/lib/concrete_ident/concrete_ident.mli index 21c587206..037d4dde7 100644 --- a/engine/lib/concrete_ident/concrete_ident.mli +++ b/engine/lib/concrete_ident/concrete_ident.mli @@ -71,6 +71,8 @@ val map_path_strings : f:(string -> string) -> t -> t is a hack for Import_thir so that we can generically produce identifiers for any integer type, please do not use it elsewhere. *) +val is_constructor : t -> bool + type comparator_witness val comparator : (t, comparator_witness) Base.Comparator.comparator From ee47a83946a60e0d6087bea4e060703fea09778e Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 10:28:10 +0100 Subject: [PATCH 12/21] Allow type aliases in concrete idents. --- engine/lib/concrete_ident/concrete_ident.ml | 1 + engine/lib/concrete_ident/concrete_ident_view.ml | 3 ++- engine/lib/concrete_ident/concrete_ident_view_types.ml | 2 ++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/engine/lib/concrete_ident/concrete_ident.ml b/engine/lib/concrete_ident/concrete_ident.ml index 64459c6e9..4ea37044d 100644 --- a/engine/lib/concrete_ident/concrete_ident.ml +++ b/engine/lib/concrete_ident/concrete_ident.ml @@ -577,6 +577,7 @@ module MakeRenderAPI (NP : NAME_POLICY) : RENDER_API = struct | `Mod n | `Struct n | `Union n + | `TyAlias n | `Enum n -> prefix "t" (dstr n) diff --git a/engine/lib/concrete_ident/concrete_ident_view.ml b/engine/lib/concrete_ident/concrete_ident_view.ml index 88b16e879..7714bc35d 100644 --- a/engine/lib/concrete_ident/concrete_ident_view.ml +++ b/engine/lib/concrete_ident/concrete_ident_view.ml @@ -75,6 +75,7 @@ let rec poly : | AssocFn -> `Fn (assert_value_ns did) |> mk_associated_item | AssocConst -> `Const (assert_value_ns did) |> mk_associated_item | AssocTy -> `Type (assert_type_ns did) |> mk_associated_item + | TyAlias -> `TyAlias (assert_type_ns did) | Field -> let constructor = let parent = Assert.parent did in @@ -126,7 +127,7 @@ let rec poly : (match List.last_exn (Explicit_def_id.to_def_id did).path with | { data = GlobalAsm; disambiguator } -> into_d did disambiguator | _ -> broken_invariant "last path chunk to be GlobalAsm" did) - | TyAlias | TyParam | ConstParam | InlineConst | LifetimeParam | Closure + | TyParam | ConstParam | InlineConst | LifetimeParam | Closure | SyntheticCoroutineBody -> (* It should be impossible for such items to ever be referenced by anyting in hax. *) broken_invariant diff --git a/engine/lib/concrete_ident/concrete_ident_view_types.ml b/engine/lib/concrete_ident/concrete_ident_view_types.ml index 3655fc177..8235737a9 100644 --- a/engine/lib/concrete_ident/concrete_ident_view_types.ml +++ b/engine/lib/concrete_ident/concrete_ident_view_types.ml @@ -126,6 +126,7 @@ module RelPath = struct | `TraitAlias of 'name | `Foreign of 'disambiguator | `ForeignTy of 'name + | `TyAlias of 'name | `ExternCrate of 'name | `Opaque of 'disambiguator (** This is e.g.: {[ @@ -184,6 +185,7 @@ module RelPath = struct | `Enum n | `Struct n | `Union n + | `TyAlias n | `TraitAlias n | `Fn n | `Const n From 2bab5db97e4bb2d1d1e85dfeb3e426366ee69246 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 11:01:41 +0100 Subject: [PATCH 13/21] We shouldn't produce aliases for Quote items in bundles. --- engine/lib/dependencies.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/engine/lib/dependencies.ml b/engine/lib/dependencies.ml index 8ea3f7eb2..b743b4dc6 100644 --- a/engine/lib/dependencies.ml +++ b/engine/lib/dependencies.ml @@ -527,6 +527,7 @@ module Make (F : Features.T) = struct when List.for_all variants ~f:(fun variant -> variant.is_record) && Concrete_ident.is_constructor from_id -> None + | Quote _ -> None | _ -> Some { attrs; span = origin_item.span; ident = from_id; v }) in let rename = From 00d829ac51bd2ddbfa0823780ab5ce3bf566ad11 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 12:02:17 +0100 Subject: [PATCH 14/21] Make sure refinement types end up in their original module. --- engine/lib/concrete_ident/concrete_ident_view.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/engine/lib/concrete_ident/concrete_ident_view.ml b/engine/lib/concrete_ident/concrete_ident_view.ml index 7714bc35d..35bd07a23 100644 --- a/engine/lib/concrete_ident/concrete_ident_view.ml +++ b/engine/lib/concrete_ident/concrete_ident_view.ml @@ -200,4 +200,8 @@ let of_def_id (did : Explicit_def_id.t) : t = "A `Mod` identifier must a `TypeNs` as its last path" m) ns_chunks in + let mod_path = + List.filter mod_path ~f:(fun ds -> + String.is_prefix ds.data ~prefix:"hax__autogenerated_refinement_" |> not) + in { rel_path; mod_path } From c7f4187e325f95a8e9405391411abb058bdb853f Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 12:02:54 +0100 Subject: [PATCH 15/21] Correct origin for quote items. --- engine/lib/phases/phase_transform_hax_lib_inline.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/engine/lib/phases/phase_transform_hax_lib_inline.ml b/engine/lib/phases/phase_transform_hax_lib_inline.ml index 3ae769b32..0e3377fc5 100644 --- a/engine/lib/phases/phase_transform_hax_lib_inline.ml +++ b/engine/lib/phases/phase_transform_hax_lib_inline.ml @@ -179,9 +179,9 @@ module%inlined_contents Make (F : Features.T) = struct | _ -> None in let* uid = Attrs.uid item.attrs in - let* role, _ = find_parent_item uid in + let* role, parent = find_parent_item uid in let*? () = [%equal: Attr_payloads.AssocRole.t] ItemQuote role in - let replace = Attrs.late_skip item.attrs in + let replace = Attrs.late_skip parent.attrs in let* role = Attrs.find_unique_attr ~f:(function ItemQuote q -> Some q | _ -> None) @@ -189,8 +189,8 @@ module%inlined_contents Make (F : Features.T) = struct in let origin : item_quote_origin = { - item_kind = UA.kind_of_item item; - item_ident = item.ident; + item_kind = UA.kind_of_item parent; + item_ident = parent.ident; position = (if replace then `Replace else From 2a3e840fdadc83672487ffc6c3deaacc04aa481c Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 16:41:54 +0100 Subject: [PATCH 16/21] Lower-case prefix for anonymous constants. --- engine/lib/concrete_ident/concrete_ident.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/engine/lib/concrete_ident/concrete_ident.ml b/engine/lib/concrete_ident/concrete_ident.ml index 4ea37044d..e36aa0aad 100644 --- a/engine/lib/concrete_ident/concrete_ident.ml +++ b/engine/lib/concrete_ident/concrete_ident.ml @@ -521,7 +521,9 @@ module MakeRenderAPI (NP : NAME_POLICY) : RENDER_API = struct let dstr s = NameAst.UnsafeString (render_disambiguated s) in let _render_chunk = render_chunk ~namespace in match chunk with - | `AnonConst d -> prefix_d "anon_const" d + | `AnonConst d -> + prefix ~global:true ~disable_when:[ `SameCase ] "anon_const" + (NameAst.UnsafeString (Int64.to_string d)) | `Use d -> prefix_d "use" d | `Foreign d -> prefix_d "foreign" d | `GlobalAsm d -> prefix_d "global_asm" d From 4e8dcb0aec85832eb5577b052f61ef46baa40eff Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 16:42:13 +0100 Subject: [PATCH 17/21] Test snapshots for new naming. --- .../snapshots/toolchain__assert into-coq.snap | 6 +- .../toolchain__assert into-ssprove.snap | 2 +- ...oolchain__attribute-opaque into-fstar.snap | 14 +- .../toolchain__attributes into-fstar.snap | 70 +- ...in__constructor-as-closure into-fstar.snap | 4 +- .../toolchain__cyclic-modules into-fstar.snap | 366 +++--- .../snapshots/toolchain__dyn into-fstar.snap | 2 +- .../toolchain__enum-repr into-coq.snap | 20 +- .../toolchain__enum-repr into-fstar.snap | 21 +- .../toolchain__enum-repr into-ssprove.snap | 24 +- .../toolchain__generics into-fstar.snap | 20 +- .../snapshots/toolchain__guards into-coq.snap | 4 +- .../toolchain__include-flag into-coq.snap | 2 +- .../toolchain__include-flag into-fstar.snap | 2 +- .../toolchain__interface-only into-fstar.snap | 6 +- .../toolchain__let-else into-coq.snap | 2 +- .../toolchain__literals into-coq.snap | 44 +- .../toolchain__literals into-fstar.snap | 24 +- .../toolchain__loops into-fstar.snap | 10 +- ..._mut-ref-functionalization into-fstar.snap | 2 +- .../toolchain__naming into-fstar.snap | 38 +- .../toolchain__reordering into-coq.snap | 8 +- .../toolchain__reordering into-ssprove.snap | 204 ++- .../toolchain__side-effects into-fstar.snap | 56 +- .../toolchain__side-effects into-ssprove.snap | 1100 +++++++++++++++-- .../snapshots/toolchain__slices into-coq.snap | 2 +- .../toolchain__traits into-fstar.snap | 24 +- 27 files changed, 1594 insertions(+), 483 deletions(-) diff --git a/test-harness/src/snapshots/toolchain__assert into-coq.snap b/test-harness/src/snapshots/toolchain__assert into-coq.snap index a000cc9f9..cb9f1f346 100644 --- a/test-harness/src/snapshots/toolchain__assert into-coq.snap +++ b/test-harness/src/snapshots/toolchain__assert into-coq.snap @@ -45,14 +45,14 @@ Import RecordSetNotations. Definition asserts (_ : unit) : unit := let _ := assert (true) in - let _ := assert (t_PartialEq_f_eq (1) (1)) in + let _ := assert (f_eq (1) (1)) in let _ := match (2,2) with | (left_val,right_val) => - assert (t_PartialEq_f_eq (left_val) (right_val)) + assert (f_eq (left_val) (right_val)) end in let _ := match (1,2) with | (left_val,right_val) => - assert (negb (t_PartialEq_f_eq (left_val) (right_val))) + assert (f_not (f_eq (left_val) (right_val))) end in tt. ''' diff --git a/test-harness/src/snapshots/toolchain__assert into-ssprove.snap b/test-harness/src/snapshots/toolchain__assert into-ssprove.snap index c535a7727..cb482b20c 100644 --- a/test-harness/src/snapshots/toolchain__assert into-ssprove.snap +++ b/test-harness/src/snapshots/toolchain__assert into-ssprove.snap @@ -65,7 +65,7 @@ Equations asserts {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) end in letb _ := matchb prod_b (ret_both (1 : int32),ret_both (2 : int32)) with | '(left_val,right_val) => - solve_lift (assert (not (left_val =.? right_val))) + solve_lift (assert (f_not (left_val =.? right_val))) end in solve_lift (ret_both (tt : 'unit)) : both L1 I1 'unit. Fail Next Obligation. diff --git a/test-harness/src/snapshots/toolchain__attribute-opaque into-fstar.snap b/test-harness/src/snapshots/toolchain__attribute-opaque into-fstar.snap index aafda7a36..c3f6323aa 100644 --- a/test-harness/src/snapshots/toolchain__attribute-opaque into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__attribute-opaque into-fstar.snap @@ -86,14 +86,14 @@ val v_C': u8 let v_C = v_C' assume -val impl__S1__f_s1': Prims.unit -> Prims.Pure Prims.unit Prims.l_True (fun _ -> Prims.l_True) +val impl_S1__ff_s1': Prims.unit -> Prims.Pure Prims.unit Prims.l_True (fun _ -> Prims.l_True) -let impl__S1__f_s1 = impl__S1__f_s1' +let impl_S1__ff_s1 = impl_S1__ff_s1' assume -val impl__S2__f_s2': Prims.unit -> Prims.Pure Prims.unit Prims.l_True (fun _ -> Prims.l_True) +val impl_S2__ff_s2': Prims.unit -> Prims.Pure Prims.unit Prims.l_True (fun _ -> Prims.l_True) -let impl__S2__f_s2 = impl__S2__f_s2' +let impl_S2__ff_s2 = impl_S2__ff_s2' ''' "Attribute_opaque.fsti" = ''' module Attribute_opaque @@ -124,7 +124,7 @@ class t_T (v_Self: Type0) = { f_d_pre:Prims.unit -> Type0; f_d_post:Prims.unit -> Prims.unit -> Type0; f_d:x0: Prims.unit -> Prims.Pure Prims.unit (f_d_pre x0) (fun result -> f_d_post x0 result); - f_m_pre:self___: v_Self -> x: u8 -> pred: Type0{x =. mk_u8 0 ==> pred}; + f_m_pre:self_: v_Self -> x: u8 -> pred: Type0{x =. mk_u8 0 ==> pred}; f_m_post:v_Self -> u8 -> bool -> Type0; f_m:x0: v_Self -> x1: u8 -> Prims.Pure bool (f_m_pre x0 x1) (fun result -> f_m_post x0 x1 result) } @@ -146,9 +146,9 @@ val v_C:u8 type t_S1 = | S1 : t_S1 -val impl__S1__f_s1: Prims.unit -> Prims.Pure Prims.unit Prims.l_True (fun _ -> Prims.l_True) +val impl_S1__ff_s1: Prims.unit -> Prims.Pure Prims.unit Prims.l_True (fun _ -> Prims.l_True) type t_S2 = | S2 : t_S2 -val impl__S2__f_s2: Prims.unit -> Prims.Pure Prims.unit Prims.l_True (fun _ -> Prims.l_True) +val impl_S2__ff_s2: Prims.unit -> Prims.Pure Prims.unit Prims.l_True (fun _ -> Prims.l_True) ''' diff --git a/test-harness/src/snapshots/toolchain__attributes into-fstar.snap b/test-harness/src/snapshots/toolchain__attributes into-fstar.snap index aed002a10..2cd940219 100644 --- a/test-harness/src/snapshots/toolchain__attributes into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__attributes into-fstar.snap @@ -36,8 +36,8 @@ let doing_nothing (_: Prims.unit) : Prims.Pure Prims.unit (requires true) (ensures - fun v__x -> - let v__x:Prims.unit = v__x in + fun e_x -> + let e_x:Prims.unit = e_x in true) = () let basically_a_constant (_: Prims.unit) @@ -92,16 +92,6 @@ open FStar.Mul unfold type t_Int = int -unfold let add x y = x + y - -unfold instance impl: Core.Ops.Arith.t_Sub t_Int t_Int = - { - f_Output = t_Int; - f_sub_pre = (fun (self: t_Int) (other: t_Int) -> true); - f_sub_post = (fun (self: t_Int) (other: t_Int) (out: t_Int) -> true); - f_sub = fun (self: t_Int) (other: t_Int) -> self + other - } - [@@ FStar.Tactics.Typeclasses.tcinstance] assume val impl_1': Core.Clone.t_Clone t_Int @@ -113,6 +103,16 @@ assume val impl': Core.Marker.t_Copy t_Int let impl = impl' + +unfold let add x y = x + y + +unfold instance impl: Core.Ops.Arith.t_Sub t_Int t_Int = + { + f_Output = t_Int; + f_sub_pre = (fun (self: t_Int) (other: t_Int) -> true); + f_sub_post = (fun (self: t_Int) (other: t_Int) (out: t_Int) -> true); + f_sub = fun (self: t_Int) (other: t_Int) -> self + other + } ''' "Attributes.Issue_1266_.fst" = ''' module Attributes.Issue_1266_ @@ -146,12 +146,12 @@ let v_MAX: usize = mk_usize 10 type t_SafeIndex = { f_i:f_i: usize{f_i <. v_MAX} } -let impl__SafeIndex__new (i: usize) : Core.Option.t_Option t_SafeIndex = +let impl_SafeIndex__new (i: usize) : Core.Option.t_Option t_SafeIndex = if i <. v_MAX then Core.Option.Option_Some ({ f_i = i } <: t_SafeIndex) <: Core.Option.t_Option t_SafeIndex else Core.Option.Option_None <: Core.Option.t_Option t_SafeIndex -let impl__SafeIndex__as_usize (self: t_SafeIndex) : usize = self.f_i +let impl_SafeIndex__as_usize (self: t_SafeIndex) : usize = self.f_i [@@ FStar.Tactics.Typeclasses.tcinstance] let impl_1 (#v_T: Type0) : Core.Ops.Index.t_Index (t_Array v_T (mk_usize 10)) t_SafeIndex = @@ -208,7 +208,7 @@ let impl: t_Operation t_ViaAdd = } [@@ FStar.Tactics.Typeclasses.tcinstance] -let impl_1: t_Operation t_ViaMul = +let impl_Operation_for_ViaMul: t_Operation t_ViaMul = { f_double_pre = @@ -225,8 +225,8 @@ let impl_1: t_Operation t_ViaMul = } class t_TraitWithRequiresAndEnsures (v_Self: Type0) = { - f_method_pre:self___: v_Self -> x: u8 -> pred: Type0{x <. mk_u8 100 ==> pred}; - f_method_post:self___: v_Self -> x: u8 -> r: u8 -> pred: Type0{pred ==> r >. mk_u8 88}; + f_method_pre:self_: v_Self -> x: u8 -> pred: Type0{x <. mk_u8 100 ==> pred}; + f_method_post:self_: v_Self -> x: u8 -> r: u8 -> pred: Type0{pred ==> r >. mk_u8 88}; f_method:x0: v_Self -> x1: u8 -> Prims.Pure u8 (f_method_pre x0 x1) (fun result -> f_method_post x0 x1 result) } @@ -249,7 +249,7 @@ type t_Foo = | Foo : u8 -> t_Foo let impl: Core.Ops.Arith.t_Add t_Foo t_Foo = { f_Output = t_Foo; - f_add_pre = (fun (self___: t_Foo) (rhs: t_Foo) -> self___._0 <. (mk_u8 255 -! rhs._0 <: u8)); + f_add_pre = (fun (self_: t_Foo) (rhs: t_Foo) -> self_._0 <. (mk_u8 255 -! rhs._0 <: u8)); f_add_post = (fun (self: t_Foo) (rhs: t_Foo) (out: t_Foo) -> true); f_add = fun (self: t_Foo) (rhs: t_Foo) -> Foo (self._0 +! rhs._0) <: t_Foo } @@ -260,8 +260,8 @@ let impl_1: Core.Ops.Arith.t_Mul t_Foo t_Foo = f_Output = t_Foo; f_mul_pre = - (fun (self___: t_Foo) (rhs: t_Foo) -> - rhs._0 =. mk_u8 0 || self___._0 <. (mk_u8 255 /! rhs._0 <: u8)); + (fun (self_: t_Foo) (rhs: t_Foo) -> rhs._0 =. mk_u8 0 || self_._0 <. (mk_u8 255 /! rhs._0 <: u8) + ); f_mul_post = (fun (self: t_Foo) (rhs: t_Foo) (out: t_Foo) -> true); f_mul = fun (self: t_Foo) (rhs: t_Foo) -> Foo (self._0 *! rhs._0) <: t_Foo } @@ -281,15 +281,15 @@ type t_MyArray = | MyArray : t_Array u8 (mk_usize 10) -> t_MyArray Done vitae ullamcorper est. Curabitur id dui eget sem viverra interdum. *) let mutation_example - (use_generic_update_at: t_MyArray) - (use_specialized_update_at: t_Slice u8) + (uuse_generic_update_at: t_MyArray) + (uuse_specialized_update_at: t_Slice u8) (specialized_as_well: Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global) : (t_MyArray & t_Slice u8 & Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global) = - let use_generic_update_at:t_MyArray = - Rust_primitives.Hax.update_at use_generic_update_at (mk_usize 2) (mk_u8 0) + let uuse_generic_update_at:t_MyArray = + Rust_primitives.Hax.update_at uuse_generic_update_at (mk_usize 2) (mk_u8 0) in - let use_specialized_update_at:t_Slice u8 = - Rust_primitives.Hax.Monomorphized_update_at.update_at_usize use_specialized_update_at + let uuse_specialized_update_at:t_Slice u8 = + Rust_primitives.Hax.Monomorphized_update_at.update_at_usize uuse_specialized_update_at (mk_usize 2) (mk_u8 0) in @@ -298,7 +298,7 @@ let mutation_example (mk_usize 2) (mk_u8 0) in - use_generic_update_at, use_specialized_update_at, specialized_as_well + uuse_generic_update_at, uuse_specialized_update_at, specialized_as_well <: (t_MyArray & t_Slice u8 & Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global) @@ -306,7 +306,7 @@ let mutation_example let impl: Core.Ops.Index.t_Index t_MyArray usize = { f_Output = u8; - f_index_pre = (fun (self___: t_MyArray) (index: usize) -> index <. v_MAX); + f_index_pre = (fun (self_: t_MyArray) (index: usize) -> index <. v_MAX); f_index_post = (fun (self: t_MyArray) (index: usize) (out: u8) -> true); f_index = fun (self: t_MyArray) (index: usize) -> self.[ index ] } @@ -339,7 +339,7 @@ let t_NoE = { let _, out:(Core.Str.Iter.t_Chars & bool) = Core.Iter.Traits.Iterator.f_any #Core.Str.Iter.t_Chars #FStar.Tactics.Typeclasses.solve - (Core.Str.impl__str__chars (Core.Ops.Deref.f_deref #Alloc.String.t_String + (Core.Str.impl_str__chars (Core.Ops.Deref.f_deref #Alloc.String.t_String #FStar.Tactics.Typeclasses.solve x <: @@ -513,13 +513,13 @@ let swap_and_mut_req_ens (x y: u32) let hax_temp_output:u32 = x +! y in x, y, hax_temp_output <: (u32 & u32 & u32) -let issue_844_ (v__x: u8) +let issue_844_ (e_x: u8) : Prims.Pure u8 Prims.l_True (ensures - fun v__x_future -> - let v__x_future:u8 = v__x_future in - true) = v__x + fun e_x_future -> + let e_x_future:u8 = e_x_future in + true) = e_x let add3_lemma (x: u32) : Lemma Prims.l_True @@ -533,7 +533,7 @@ type t_Foo = { f_z:f_z: u32{((f_y +! f_x <: u32) +! f_z <: u32) >. mk_u32 3} } -let inlined_code__V: u8 = mk_u8 12 +let inlined_code__v_V: u8 = mk_u8 12 let before_inlined_code = "example before" @@ -542,7 +542,7 @@ let inlined_code (foo: t_Foo) : Prims.unit = let _:Prims.unit = let x = foo.f_x in let { f_y = y } = foo in - add3 ((fun _ -> 3ul) foo) vv_a inlined_code__V y + add3 ((fun _ -> 3ul) foo) vv_a inlined_code__v_V y in () diff --git a/test-harness/src/snapshots/toolchain__constructor-as-closure into-fstar.snap b/test-harness/src/snapshots/toolchain__constructor-as-closure into-fstar.snap index 57b89460f..680e6cd15 100644 --- a/test-harness/src/snapshots/toolchain__constructor-as-closure into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__constructor-as-closure into-fstar.snap @@ -34,13 +34,13 @@ open FStar.Mul type t_Test = | Test : i32 -> t_Test -let impl__Test__test (x: Core.Option.t_Option i32) : Core.Option.t_Option t_Test = +let impl_Test__test (x: Core.Option.t_Option i32) : Core.Option.t_Option t_Test = Core.Option.impl__map #i32 #t_Test x Test type t_Context = | Context_A : i32 -> t_Context | Context_B : i32 -> t_Context -let impl__Context__test (x: Core.Option.t_Option i32) : Core.Option.t_Option t_Context = +let impl_Context__test (x: Core.Option.t_Option i32) : Core.Option.t_Option t_Context = Core.Option.impl__map #i32 #t_Context x Context_B ''' diff --git a/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap b/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap index e3ef061c7..d0f4a2af0 100644 --- a/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__cyclic-modules into-fstar.snap @@ -32,34 +32,26 @@ module Cyclic_modules.B open Core open FStar.Mul -include Cyclic_modules.Cyclic_bundle_367033742 {g as g} +include Cyclic_modules.Bundle {g as g} ''' -"Cyclic_modules.C.fst" = ''' -module Cyclic_modules.C -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -let i (_: Prims.unit) : Prims.unit = () -''' -"Cyclic_modules.Cyclic_bundle_367033742.fst" = ''' -module Cyclic_modules.Cyclic_bundle_367033742 +"Cyclic_modules.Bundle.fst" = ''' +module Cyclic_modules.Bundle #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul let f (_: Prims.unit) : Prims.unit = () +let h2 (_: Prims.unit) : Prims.unit = Cyclic_modules.C.i () + let g (_: Prims.unit) : Prims.unit = f () let h (_: Prims.unit) : Prims.unit = let _:Prims.unit = g () in Cyclic_modules.C.i () - -let h2 (_: Prims.unit) : Prims.unit = Cyclic_modules.C.i () ''' -"Cyclic_modules.D.Cyclic_bundle_81544935.fst" = ''' -module Cyclic_modules.D.Cyclic_bundle_81544935 +"Cyclic_modules.Bundle_d.fst" = ''' +module Cyclic_modules.Bundle_d #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul @@ -72,89 +64,174 @@ let de1 (_: Prims.unit) : Prims.unit = e1 () let d2 (_: Prims.unit) : Prims.unit = de1 () ''' -"Cyclic_modules.D.fst" = ''' -module Cyclic_modules.D +"Cyclic_modules.Bundle_disjoint_cycle_a.fst" = ''' +module Cyclic_modules.Bundle_disjoint_cycle_a #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -include Cyclic_modules.D.Cyclic_bundle_81544935 {d1 as d1} +let g (_: Prims.unit) : Prims.unit = () + +let h (_: Prims.unit) : Prims.unit = () -include Cyclic_modules.D.Cyclic_bundle_81544935 {d2 as d2} +let f (_: Prims.unit) : Prims.unit = h () + +let i (_: Prims.unit) : Prims.unit = g () ''' -"Cyclic_modules.De.fst" = ''' -module Cyclic_modules.De +"Cyclic_modules.Bundle_enums_a.fst" = ''' +module Cyclic_modules.Bundle_enums_a #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -include Cyclic_modules.D.Cyclic_bundle_81544935 {de1 as de1} +type t_U = + | U_A : t_U + | U_B : t_U + | U_C : Alloc.Vec.t_Vec t_T Alloc.Alloc.t_Global -> t_U + +and t_T__from__enums_b = + | T_A : t_T__from__enums_b + | T_B : t_T__from__enums_b + | T_C : Alloc.Vec.t_Vec t_T Alloc.Alloc.t_Global -> t_T__from__enums_b + +and t_T = + | T_A__from__enums_a : t_T + | T_B__from__enums_a : t_T + | T_C__from__enums_a : Alloc.Vec.t_Vec t_U Alloc.Alloc.t_Global -> t_T + | T_D : Alloc.Vec.t_Vec t_T__from__enums_b Alloc.Alloc.t_Global -> t_T + +let f (_: Prims.unit) : t_T__from__enums_b = T_A <: t_T__from__enums_b ''' -"Cyclic_modules.Disjoint_cycle_a.Cyclic_bundle_177270903.fst" = ''' -module Cyclic_modules.Disjoint_cycle_a.Cyclic_bundle_177270903 +"Cyclic_modules.Bundle_late_skip_a.fst" = ''' +module Cyclic_modules.Bundle_late_skip_a #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -let g (_: Prims.unit) : Prims.unit = () +let rec f (_: Prims.unit) : Prims.Pure Prims.unit (requires true) (fun _ -> Prims.l_True) = + f__from__late_skip_a () -let h (_: Prims.unit) : Prims.unit = () +and f__from__late_skip_a (_: Prims.unit) : Prims.unit = f () +''' +"Cyclic_modules.Bundle_m1.fst" = ''' +module Cyclic_modules.Bundle_m1 +#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" +open Core +open FStar.Mul -let f (_: Prims.unit) : Prims.unit = h () +let d (_: Prims.unit) : Prims.unit = () -let i (_: Prims.unit) : Prims.unit = g () +let c (_: Prims.unit) : Prims.unit = () + +let a (_: Prims.unit) : Prims.unit = c () + +let b (_: Prims.unit) : Prims.unit = + let _:Prims.unit = a () in + d () ''' -"Cyclic_modules.Disjoint_cycle_a.fst" = ''' -module Cyclic_modules.Disjoint_cycle_a +"Cyclic_modules.Bundle_rec1_same_name.fst" = ''' +module Cyclic_modules.Bundle_rec1_same_name #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -include Cyclic_modules.Disjoint_cycle_a.Cyclic_bundle_177270903 {f as f} +let rec f (x: i32) : i32 = + if x >. mk_i32 0 then f__from__rec1_same_name (x -! mk_i32 1 <: i32) else mk_i32 0 -include Cyclic_modules.Disjoint_cycle_a.Cyclic_bundle_177270903 {g as g} +and f__from__rec1_same_name (x: i32) : i32 = f x ''' -"Cyclic_modules.Disjoint_cycle_b.fst" = ''' -module Cyclic_modules.Disjoint_cycle_b +"Cyclic_modules.Bundle_typ_a.fst" = ''' +module Cyclic_modules.Bundle_typ_a #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -include Cyclic_modules.Disjoint_cycle_a.Cyclic_bundle_177270903 {h as h} +type t_T1 = | T1_T1 : t_T1 + +type t_T = | T_T : t_T1 -> t_T + +let t_T1_cast_to_repr (x: t_T1) : isize = match x <: t_T1 with | T1_T1 -> mk_isize 0 + +type t_T2 = | T2_T2 : t_T -> t_T2 + +type t_T2Rec = | T2Rec_T2 : t_TRec -> t_T2Rec + +and t_T1Rec = | T1Rec_T1 : Alloc.Boxed.t_Box t_T2Rec Alloc.Alloc.t_Global -> t_T1Rec -include Cyclic_modules.Disjoint_cycle_a.Cyclic_bundle_177270903 {i as i} +and t_TRec = + | TRec_T : t_T1Rec -> t_TRec + | TRec_Empty : t_TRec ''' -"Cyclic_modules.E.fst" = ''' -module Cyclic_modules.E +"Cyclic_modules.Bundle_variant_constructor_a.fst" = ''' +module Cyclic_modules.Bundle_variant_constructor_a #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -include Cyclic_modules.D.Cyclic_bundle_81544935 {e1 as e1} +type t_Context = + | Context_A : i32 -> t_Context + | Context_B : i32 -> t_Context + +let impl__test (x: Core.Option.t_Option i32) : Core.Option.t_Option t_Context = + Core.Option.impl__map #i32 #t_Context x Context_A + +let h (_: Prims.unit) : t_Context = Context_A (mk_i32 1) <: t_Context + +let f (_: Prims.unit) : t_Context = h () ''' -"Cyclic_modules.Enums_a.Cyclic_bundle_1009707801.fst" = ''' -module Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 +"Cyclic_modules.C.fst" = ''' +module Cyclic_modules.C #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -type t_U = - | U_A : t_U - | U_B : t_U - | U_C : Alloc.Vec.t_Vec t_T_240131830 Alloc.Alloc.t_Global -> t_U +let i (_: Prims.unit) : Prims.unit = () +''' +"Cyclic_modules.D.fst" = ''' +module Cyclic_modules.D +#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" +open Core +open FStar.Mul -and t_T_366415196 = - | T_366415196_A : t_T_366415196 - | T_366415196_B : t_T_366415196 - | T_366415196_C : Alloc.Vec.t_Vec t_T_240131830 Alloc.Alloc.t_Global -> t_T_366415196 +include Cyclic_modules.Bundle_d {d1 as d1} -and t_T_240131830 = - | T_240131830_A : t_T_240131830 - | T_240131830_B : t_T_240131830 - | T_240131830_C : Alloc.Vec.t_Vec t_U Alloc.Alloc.t_Global -> t_T_240131830 - | T_240131830_D : Alloc.Vec.t_Vec t_T_366415196 Alloc.Alloc.t_Global -> t_T_240131830 +include Cyclic_modules.Bundle_d {d2 as d2} +''' +"Cyclic_modules.De.fst" = ''' +module Cyclic_modules.De +#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" +open Core +open FStar.Mul + +include Cyclic_modules.Bundle_d {de1 as de1} +''' +"Cyclic_modules.Disjoint_cycle_a.fst" = ''' +module Cyclic_modules.Disjoint_cycle_a +#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" +open Core +open FStar.Mul + +include Cyclic_modules.Bundle_disjoint_cycle_a {f as f} -let f (_: Prims.unit) : t_T_366415196 = T_366415196_A <: t_T_366415196 +include Cyclic_modules.Bundle_disjoint_cycle_a {g as g} +''' +"Cyclic_modules.Disjoint_cycle_b.fst" = ''' +module Cyclic_modules.Disjoint_cycle_b +#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" +open Core +open FStar.Mul + +include Cyclic_modules.Bundle_disjoint_cycle_a {h as h} + +include Cyclic_modules.Bundle_disjoint_cycle_a {i as i} +''' +"Cyclic_modules.E.fst" = ''' +module Cyclic_modules.E +#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" +open Core +open FStar.Mul + +include Cyclic_modules.Bundle_d {e1 as e1} ''' "Cyclic_modules.Enums_a.fst" = ''' module Cyclic_modules.Enums_a @@ -162,15 +239,19 @@ module Cyclic_modules.Enums_a open Core open FStar.Mul -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {t_T_240131830 as t_T} +include Cyclic_modules.Bundle_enums_a {t_T as t_T} + +include Cyclic_modules.Bundle_enums_a {T_A__from__enums_a as T_A} + +include Cyclic_modules.Bundle_enums_a {T_B__from__enums_a as T_B} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {T_240131830_A as T_A} +include Cyclic_modules.Bundle_enums_a {T_C__from__enums_a as T_C} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {T_240131830_B as T_B} +include Cyclic_modules.Bundle_enums_a {_0 as _0} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {T_240131830_C as T_C} +include Cyclic_modules.Bundle_enums_a {T_D as T_D} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {T_240131830_D as T_D} +include Cyclic_modules.Bundle_enums_a {_0 as _0} ''' "Cyclic_modules.Enums_b.fst" = ''' module Cyclic_modules.Enums_b @@ -178,34 +259,27 @@ module Cyclic_modules.Enums_b open Core open FStar.Mul -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {t_U as t_U} +include Cyclic_modules.Bundle_enums_a {t_U as t_U} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {U_A as U_A} +include Cyclic_modules.Bundle_enums_a {U_A as U_A} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {U_B as U_B} +include Cyclic_modules.Bundle_enums_a {U_B as U_B} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {U_C as U_C} +include Cyclic_modules.Bundle_enums_a {U_C as U_C} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {t_T_366415196 as t_T} +include Cyclic_modules.Bundle_enums_a {_0 as _0} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {T_366415196_A as T_A} +include Cyclic_modules.Bundle_enums_a {t_T__from__enums_b as t_T} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {T_366415196_B as T_B} +include Cyclic_modules.Bundle_enums_a {T_A as T_A} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {T_366415196_C as T_C} +include Cyclic_modules.Bundle_enums_a {T_B as T_B} -include Cyclic_modules.Enums_a.Cyclic_bundle_1009707801 {f as f} -''' -"Cyclic_modules.Late_skip_a.Cyclic_bundle_658016071.fst" = ''' -module Cyclic_modules.Late_skip_a.Cyclic_bundle_658016071 -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul +include Cyclic_modules.Bundle_enums_a {T_C as T_C} -let rec ff_749016415 (_: Prims.unit) : Prims.unit = ff_377825240 () +include Cyclic_modules.Bundle_enums_a {_0 as _0} -and ff_377825240 (_: Prims.unit) : Prims.Pure Prims.unit (requires true) (fun _ -> Prims.l_True) = - ff_749016415 () +include Cyclic_modules.Bundle_enums_a {f as f} ''' "Cyclic_modules.Late_skip_a.fst" = ''' module Cyclic_modules.Late_skip_a @@ -213,7 +287,7 @@ module Cyclic_modules.Late_skip_a open Core open FStar.Mul -include Cyclic_modules.Late_skip_a.Cyclic_bundle_658016071 {ff_749016415 as f} +include Cyclic_modules.Bundle_late_skip_a {f__from__late_skip_a as f} ''' "Cyclic_modules.Late_skip_b.fst" = ''' module Cyclic_modules.Late_skip_b @@ -221,23 +295,7 @@ module Cyclic_modules.Late_skip_b open Core open FStar.Mul -include Cyclic_modules.Late_skip_a.Cyclic_bundle_658016071 {ff_377825240 as f} -''' -"Cyclic_modules.M1.Cyclic_bundle_892895908.fst" = ''' -module Cyclic_modules.M1.Cyclic_bundle_892895908 -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -let d (_: Prims.unit) : Prims.unit = () - -let c (_: Prims.unit) : Prims.unit = () - -let a (_: Prims.unit) : Prims.unit = c () - -let b (_: Prims.unit) : Prims.unit = - let _:Prims.unit = a () in - d () +include Cyclic_modules.Bundle_late_skip_a {f as f} ''' "Cyclic_modules.M1.fst" = ''' module Cyclic_modules.M1 @@ -245,7 +303,7 @@ module Cyclic_modules.M1 open Core open FStar.Mul -include Cyclic_modules.M1.Cyclic_bundle_892895908 {a as a} +include Cyclic_modules.Bundle_m1 {a as a} ''' "Cyclic_modules.M2.fst" = ''' module Cyclic_modules.M2 @@ -253,11 +311,11 @@ module Cyclic_modules.M2 open Core open FStar.Mul -include Cyclic_modules.M1.Cyclic_bundle_892895908 {d as d} +include Cyclic_modules.Bundle_m1 {d as d} -include Cyclic_modules.M1.Cyclic_bundle_892895908 {b as b} +include Cyclic_modules.Bundle_m1 {b as b} -include Cyclic_modules.M1.Cyclic_bundle_892895908 {c as c} +include Cyclic_modules.Bundle_m1 {c as c} ''' "Cyclic_modules.Rec.fst" = ''' module Cyclic_modules.Rec @@ -289,24 +347,13 @@ and g1 (x: t_T) : t_T = | T_t1 -> g2 x | T_t2 -> T_t1 <: t_T ''' -"Cyclic_modules.Rec1_same_name.Cyclic_bundle_563905053.fst" = ''' -module Cyclic_modules.Rec1_same_name.Cyclic_bundle_563905053 -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -let rec ff_533409751 (x: i32) : i32 = ff_91805216 x - -and ff_91805216 (x: i32) : i32 = - if x >. mk_i32 0 then ff_533409751 (x -! mk_i32 1 <: i32) else mk_i32 0 -''' "Cyclic_modules.Rec1_same_name.fst" = ''' module Cyclic_modules.Rec1_same_name #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" open Core open FStar.Mul -include Cyclic_modules.Rec1_same_name.Cyclic_bundle_563905053 {ff_533409751 as f} +include Cyclic_modules.Bundle_rec1_same_name {f__from__rec1_same_name as f} ''' "Cyclic_modules.Rec2_same_name.fst" = ''' module Cyclic_modules.Rec2_same_name @@ -314,29 +361,7 @@ module Cyclic_modules.Rec2_same_name open Core open FStar.Mul -include Cyclic_modules.Rec1_same_name.Cyclic_bundle_563905053 {ff_91805216 as f} -''' -"Cyclic_modules.Typ_a.Cyclic_bundle_830459646.fst" = ''' -module Cyclic_modules.Typ_a.Cyclic_bundle_830459646 -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -type t_T1 = | T1_T1 : t_T1 - -type t_T = | T_T : t_T1 -> t_T - -let t_T1_cast_to_repr (x: t_T1) : isize = match x <: t_T1 with | T1_T1 -> mk_isize 0 - -type t_T2 = | T2_T2 : t_T -> t_T2 - -type t_TRec = - | TRec_T : t_T1Rec -> t_TRec - | TRec_Empty : t_TRec - -and t_T2Rec = | T2Rec_T2 : t_TRec -> t_T2Rec - -and t_T1Rec = | T1Rec_T1 : Alloc.Boxed.t_Box t_T2Rec Alloc.Alloc.t_Global -> t_T1Rec +include Cyclic_modules.Bundle_rec1_same_name {f as f} ''' "Cyclic_modules.Typ_a.fst" = ''' module Cyclic_modules.Typ_a @@ -344,15 +369,19 @@ module Cyclic_modules.Typ_a open Core open FStar.Mul -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {t_TRec as t_TRec} +include Cyclic_modules.Bundle_typ_a {t_TRec as t_TRec} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {TRec_T as TRec_T} +include Cyclic_modules.Bundle_typ_a {TRec_T as TRec_T} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {TRec_Empty as TRec_Empty} +include Cyclic_modules.Bundle_typ_a {_0 as _0} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {t_T as t_T} +include Cyclic_modules.Bundle_typ_a {TRec_Empty as TRec_Empty} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {T_T as T_T} +include Cyclic_modules.Bundle_typ_a {t_T as t_T} + +include Cyclic_modules.Bundle_typ_a {T_T as T_T} + +include Cyclic_modules.Bundle_typ_a {_0 as _0} ''' "Cyclic_modules.Typ_b.fst" = ''' module Cyclic_modules.Typ_b @@ -360,40 +389,29 @@ module Cyclic_modules.Typ_b open Core open FStar.Mul -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {t_T1Rec as t_T1Rec} +include Cyclic_modules.Bundle_typ_a {t_T1Rec as t_T1Rec} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {T1Rec_T1 as T1Rec_T1} +include Cyclic_modules.Bundle_typ_a {T1Rec_T1 as T1Rec_T1} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {t_T2Rec as t_T2Rec} +include Cyclic_modules.Bundle_typ_a {_0 as _0} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {T2Rec_T2 as T2Rec_T2} +include Cyclic_modules.Bundle_typ_a {t_T2Rec as t_T2Rec} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {t_T1_cast_to_repr as t_T1_cast_to_repr} +include Cyclic_modules.Bundle_typ_a {T2Rec_T2 as T2Rec_T2} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {t_T1 as t_T1} +include Cyclic_modules.Bundle_typ_a {_0 as _0} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {T1_T1 as T1_T1} +include Cyclic_modules.Bundle_typ_a {t_T1_cast_to_repr as t_T1_cast_to_repr} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {t_T2 as t_T2} +include Cyclic_modules.Bundle_typ_a {t_T1 as t_T1} -include Cyclic_modules.Typ_a.Cyclic_bundle_830459646 {T2_T2 as T2_T2} -''' -"Cyclic_modules.Variant_constructor_a.Cyclic_bundle_748213522.fst" = ''' -module Cyclic_modules.Variant_constructor_a.Cyclic_bundle_748213522 -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -type t_Context = - | Context_A : i32 -> t_Context - | Context_B : i32 -> t_Context +include Cyclic_modules.Bundle_typ_a {T1_T1 as T1_T1} -let test (x: Core.Option.t_Option i32) : Core.Option.t_Option t_Context = - Core.Option.impl__map #i32 #t_Context x Context_A +include Cyclic_modules.Bundle_typ_a {t_T2 as t_T2} -let h (_: Prims.unit) : t_Context = Context_A (mk_i32 1) <: t_Context +include Cyclic_modules.Bundle_typ_a {T2_T2 as T2_T2} -let f (_: Prims.unit) : t_Context = h () +include Cyclic_modules.Bundle_typ_a {_0 as _0} ''' "Cyclic_modules.Variant_constructor_a.fst" = ''' module Cyclic_modules.Variant_constructor_a @@ -401,15 +419,19 @@ module Cyclic_modules.Variant_constructor_a open Core open FStar.Mul -include Cyclic_modules.Variant_constructor_a.Cyclic_bundle_748213522 {t_Context as t_Context} +include Cyclic_modules.Bundle_variant_constructor_a {t_Context as t_Context} + +include Cyclic_modules.Bundle_variant_constructor_a {Context_A as Context_A} + +include Cyclic_modules.Bundle_variant_constructor_a {_0 as _0} -include Cyclic_modules.Variant_constructor_a.Cyclic_bundle_748213522 {Context_A as Context_A} +include Cyclic_modules.Bundle_variant_constructor_a {Context_B as Context_B} -include Cyclic_modules.Variant_constructor_a.Cyclic_bundle_748213522 {Context_B as Context_B} +include Cyclic_modules.Bundle_variant_constructor_a {_0 as _0} -include Cyclic_modules.Variant_constructor_a.Cyclic_bundle_748213522 {f as f} +include Cyclic_modules.Bundle_variant_constructor_a {f as f} -include Cyclic_modules.Variant_constructor_a.Cyclic_bundle_748213522 {test as impl__Context__test} +include Cyclic_modules.Bundle_variant_constructor_a {impl__test as impl_Context__test} ''' "Cyclic_modules.Variant_constructor_b.fst" = ''' module Cyclic_modules.Variant_constructor_b @@ -417,7 +439,7 @@ module Cyclic_modules.Variant_constructor_b open Core open FStar.Mul -include Cyclic_modules.Variant_constructor_a.Cyclic_bundle_748213522 {h as h} +include Cyclic_modules.Bundle_variant_constructor_a {h as h} ''' "Cyclic_modules.fst" = ''' module Cyclic_modules @@ -425,9 +447,9 @@ module Cyclic_modules open Core open FStar.Mul -include Cyclic_modules.Cyclic_bundle_367033742 {f as f} +include Cyclic_modules.Bundle {f as f} -include Cyclic_modules.Cyclic_bundle_367033742 {h as h} +include Cyclic_modules.Bundle {h as h} -include Cyclic_modules.Cyclic_bundle_367033742 {h2 as h2} +include Cyclic_modules.Bundle {h2 as h2} ''' diff --git a/test-harness/src/snapshots/toolchain__dyn into-fstar.snap b/test-harness/src/snapshots/toolchain__dyn into-fstar.snap index c365d6103..f5e736e6c 100644 --- a/test-harness/src/snapshots/toolchain__dyn into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__dyn into-fstar.snap @@ -55,7 +55,7 @@ let print Alloc.Alloc.t_Global) : Prims.unit = let _:Prims.unit = - Std.Io.Stdio.v__print (Core.Fmt.impl_2__new_v1 (mk_usize 2) + Std.Io.Stdio.e_print (Core.Fmt.impl_2__new_v1 (mk_usize 2) (mk_usize 1) (let list = [""; "\n"] in FStar.Pervasives.assert_norm (Prims.eq2 (List.Tot.length list) 2); diff --git a/test-harness/src/snapshots/toolchain__enum-repr into-coq.snap b/test-harness/src/snapshots/toolchain__enum-repr into-coq.snap index 6209a1837..b72ba94ec 100644 --- a/test-harness/src/snapshots/toolchain__enum-repr into-coq.snap +++ b/test-harness/src/snapshots/toolchain__enum-repr into-coq.snap @@ -52,30 +52,30 @@ Inductive t_EnumWithRepr : Type := Arguments t_EnumWithRepr:clear implicits. Arguments t_EnumWithRepr. -Definition discriminant_EnumWithRepr_ExplicitDiscr1 : t_u16 := +Definition anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0 : t_u16 := 1. -Definition discriminant_EnumWithRepr_ExplicitDiscr2 : t_u16 := +Definition anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 : t_u16 := 5. Definition t_EnumWithRepr_cast_to_repr (x : t_EnumWithRepr) : t_u16 := match x with | EnumWithRepr_ExplicitDiscr1 => - discriminant_EnumWithRepr_ExplicitDiscr1 + anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0 | EnumWithRepr_ExplicitDiscr2 => - discriminant_EnumWithRepr_ExplicitDiscr2 + anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 | EnumWithRepr_ImplicitDiscrEmptyTuple => - t_Add_f_add (discriminant_EnumWithRepr_ExplicitDiscr2) (1) + f_add (anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0) (1) | EnumWithRepr_ImplicitDiscrEmptyStruct => - t_Add_f_add (discriminant_EnumWithRepr_ExplicitDiscr2) (2) + f_add (anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0) (2) end. Definition f (_ : unit) : t_u32 := - let v__x := cast (t_Add_f_add (discriminant_EnumWithRepr_ExplicitDiscr2) (0)) in - t_Add_f_add (cast (t_EnumWithRepr_cast_to_repr (EnumWithRepr_ImplicitDiscrEmptyTuple))) (cast (t_EnumWithRepr_cast_to_repr (EnumWithRepr_ImplicitDiscrEmptyStruct))). + let e_x := cast (f_add (anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0) (0)) in + f_add (cast (t_EnumWithRepr_cast_to_repr (EnumWithRepr_ImplicitDiscrEmptyTuple))) (cast (t_EnumWithRepr_cast_to_repr (EnumWithRepr_ImplicitDiscrEmptyStruct))). -Definition ff__CONST : t_u16 := - cast (t_Add_f_add (discriminant_EnumWithRepr_ExplicitDiscr1) (0)). +Definition f__v_CONST : t_u16 := + cast (f_add (anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0) (0)). Definition get_repr (x : t_EnumWithRepr) : t_u16 := t_EnumWithRepr_cast_to_repr (x). diff --git a/test-harness/src/snapshots/toolchain__enum-repr into-fstar.snap b/test-harness/src/snapshots/toolchain__enum-repr into-fstar.snap index 5dbfe9989..f81ab79a1 100644 --- a/test-harness/src/snapshots/toolchain__enum-repr into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__enum-repr into-fstar.snap @@ -39,19 +39,23 @@ type t_EnumWithRepr = | EnumWithRepr_ImplicitDiscrEmptyTuple : t_EnumWithRepr | EnumWithRepr_ImplicitDiscrEmptyStruct : t_EnumWithRepr -let discriminant_EnumWithRepr_ExplicitDiscr1: u16 = mk_u16 1 +let anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0: u16 = mk_u16 1 -let discriminant_EnumWithRepr_ExplicitDiscr2: u16 = mk_u16 5 +let anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0: u16 = mk_u16 5 let t_EnumWithRepr_cast_to_repr (x: t_EnumWithRepr) : u16 = match x <: t_EnumWithRepr with - | EnumWithRepr_ExplicitDiscr1 -> discriminant_EnumWithRepr_ExplicitDiscr1 - | EnumWithRepr_ExplicitDiscr2 -> discriminant_EnumWithRepr_ExplicitDiscr2 - | EnumWithRepr_ImplicitDiscrEmptyTuple -> discriminant_EnumWithRepr_ExplicitDiscr2 +! mk_u16 1 - | EnumWithRepr_ImplicitDiscrEmptyStruct -> discriminant_EnumWithRepr_ExplicitDiscr2 +! mk_u16 2 + | EnumWithRepr_ExplicitDiscr1 -> anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0 + | EnumWithRepr_ExplicitDiscr2 -> anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 + | EnumWithRepr_ImplicitDiscrEmptyTuple -> + anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 +! mk_u16 1 + | EnumWithRepr_ImplicitDiscrEmptyStruct -> + anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 +! mk_u16 2 let f (_: Prims.unit) : u32 = - let v__x:u16 = cast (discriminant_EnumWithRepr_ExplicitDiscr2 +! mk_u16 0 <: u16) <: u16 in + let e_x:u16 = + cast (anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 +! mk_u16 0 <: u16) <: u16 + in (cast (t_EnumWithRepr_cast_to_repr (EnumWithRepr_ImplicitDiscrEmptyTuple <: t_EnumWithRepr) <: u16 ) <: @@ -62,7 +66,8 @@ let f (_: Prims.unit) : u32 = <: u32) -let ff__CONST: u16 = cast (discriminant_EnumWithRepr_ExplicitDiscr1 +! mk_u16 0 <: u16) <: u16 +let f__v_CONST: u16 = + cast (anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0 +! mk_u16 0 <: u16) <: u16 let get_repr (x: t_EnumWithRepr) : u16 = t_EnumWithRepr_cast_to_repr x diff --git a/test-harness/src/snapshots/toolchain__enum-repr into-ssprove.snap b/test-harness/src/snapshots/toolchain__enum-repr into-ssprove.snap index 613f21e5e..3df6ab5b2 100644 --- a/test-harness/src/snapshots/toolchain__enum-repr into-ssprove.snap +++ b/test-harness/src/snapshots/toolchain__enum-repr into-ssprove.snap @@ -79,13 +79,13 @@ Equations EnumWithRepr_ImplicitDiscrEmptyStruct {L : {fset Location}} {I : Inter solve_lift (ret_both (inr (tt : 'unit) : t_EnumWithRepr)) : both L I t_EnumWithRepr. Fail Next Obligation. -Equations discriminant_EnumWithRepr_ExplicitDiscr1 {L : {fset Location}} {I : Interface} : both L I int16 := - discriminant_EnumWithRepr_ExplicitDiscr1 := +Equations anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0 {L : {fset Location}} {I : Interface} : both L I int16 := + anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0 := solve_lift (ret_both (1 : int16)) : both L I int16. Fail Next Obligation. -Equations discriminant_EnumWithRepr_ExplicitDiscr2 {L : {fset Location}} {I : Interface} : both L I int16 := - discriminant_EnumWithRepr_ExplicitDiscr2 := +Equations anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 {L : {fset Location}} {I : Interface} : both L I int16 := + anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 := solve_lift (ret_both (5 : int16)) : both L I int16. Fail Next Obligation. @@ -93,25 +93,25 @@ Equations t_EnumWithRepr_cast_to_repr {L1 : {fset Location}} {I1 : Interface} (x t_EnumWithRepr_cast_to_repr x := matchb x with | EnumWithRepr_ExplicitDiscr1_case => - solve_lift discriminant_EnumWithRepr_ExplicitDiscr1 + solve_lift anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0 | EnumWithRepr_ExplicitDiscr2_case => - solve_lift discriminant_EnumWithRepr_ExplicitDiscr2 + solve_lift anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 | EnumWithRepr_ImplicitDiscrEmptyTuple_case => - solve_lift (discriminant_EnumWithRepr_ExplicitDiscr2 .+ (ret_both (1 : int16))) + solve_lift (anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 .+ (ret_both (1 : int16))) | EnumWithRepr_ImplicitDiscrEmptyStruct_case => - solve_lift (discriminant_EnumWithRepr_ExplicitDiscr2 .+ (ret_both (2 : int16))) + solve_lift (anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 .+ (ret_both (2 : int16))) end : both L1 I1 int16. Fail Next Obligation. Equations f {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 int32 := f _ := - letb v__x := cast_int (WS2 := _) (discriminant_EnumWithRepr_ExplicitDiscr2 .+ (ret_both (0 : int16))) in + letb e_x := cast_int (WS2 := _) (anon_const_EnumWithRepr_ExplicitDiscr2__anon_const_0 .+ (ret_both (0 : int16))) in solve_lift ((cast_int (WS2 := _) (t_EnumWithRepr_cast_to_repr EnumWithRepr_ImplicitDiscrEmptyTuple)) .+ (cast_int (WS2 := _) (t_EnumWithRepr_cast_to_repr EnumWithRepr_ImplicitDiscrEmptyStruct))) : both L1 I1 int32. Fail Next Obligation. -Equations ff__CONST {L : {fset Location}} {I : Interface} : both L I int16 := - ff__CONST := - solve_lift (cast_int (WS2 := _) (discriminant_EnumWithRepr_ExplicitDiscr1 .+ (ret_both (0 : int16)))) : both L I int16. +Equations f__v_CONST {L : {fset Location}} {I : Interface} : both L I int16 := + f__v_CONST := + solve_lift (cast_int (WS2 := _) (anon_const_EnumWithRepr_ExplicitDiscr1__anon_const_0 .+ (ret_both (0 : int16)))) : both L I int16. Fail Next Obligation. Equations get_repr {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 t_EnumWithRepr) : both L1 I1 int16 := diff --git a/test-harness/src/snapshots/toolchain__generics into-fstar.snap b/test-harness/src/snapshots/toolchain__generics into-fstar.snap index b3f8a2ea9..8dcb019bf 100644 --- a/test-harness/src/snapshots/toolchain__generics into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__generics into-fstar.snap @@ -45,25 +45,25 @@ open FStar.Mul type t_Test = | Test : t_Test -let impl__Test__set_ciphersuites - (#v_S #impl_995885649_: Type0) +let impl_Test__set_ciphersuites + (#v_S #iimpl_995885649_: Type0) (#[FStar.Tactics.Typeclasses.tcresolve ()] i2: Core.Convert.t_AsRef v_S string) (#[FStar.Tactics.Typeclasses.tcresolve ()] i3: - Core.Iter.Traits.Collect.t_IntoIterator impl_995885649_) + Core.Iter.Traits.Collect.t_IntoIterator iimpl_995885649_) (self: t_Test) - (ciphers: impl_995885649_) + (ciphers: iimpl_995885649_) : Core.Result.t_Result Prims.unit Prims.unit = Core.Result.Result_Ok (() <: Prims.unit) <: Core.Result.t_Result Prims.unit Prims.unit -let impl__Test__set_alpn_protocols - (#v_S #impl_995885649_: Type0) +let impl_Test__set_alpn_protocols + (#v_S #iimpl_995885649_: Type0) (#[FStar.Tactics.Typeclasses.tcresolve ()] i2: Core.Convert.t_AsRef v_S string) (#[FStar.Tactics.Typeclasses.tcresolve ()] i3: - Core.Iter.Traits.Collect.t_IntoIterator impl_995885649_) + Core.Iter.Traits.Collect.t_IntoIterator iimpl_995885649_) (self: t_Test) - (v__protocols: impl_995885649_) + (e_protocols: iimpl_995885649_) : Core.Result.t_Result Prims.unit Prims.unit = Core.Result.Result_Ok (() <: Prims.unit) <: Core.Result.t_Result Prims.unit Prims.unit ''' @@ -152,7 +152,7 @@ class t_Foo (v_Self: Type0) = { } [@@ FStar.Tactics.Typeclasses.tcinstance] -let impl_Foo_for_usize: t_Foo usize = +let impl: t_Foo usize = { f_const_add_pre = (fun (v_N: usize) (self: usize) -> true); f_const_add_post = (fun (v_N: usize) (self: usize) (out: usize) -> true); @@ -161,6 +161,6 @@ let impl_Foo_for_usize: t_Foo usize = type t_Bar = | Bar : t_Bar -let impl__Bar__inherent_impl_generics (#v_T: Type0) (v_N: usize) (x: t_Array v_T v_N) : Prims.unit = +let impl_Bar__inherent_impl_generics (#v_T: Type0) (v_N: usize) (x: t_Array v_T v_N) : Prims.unit = () ''' diff --git a/test-harness/src/snapshots/toolchain__guards into-coq.snap b/test-harness/src/snapshots/toolchain__guards into-coq.snap index 7755eb3aa..1d605e010 100644 --- a/test-harness/src/snapshots/toolchain__guards into-coq.snap +++ b/test-harness/src/snapshots/toolchain__guards into-coq.snap @@ -106,7 +106,7 @@ Definition multiple_guards (x : t_Option ((t_Result ((t_i32)) ((t_i32))))) : t_i | _ => match match x with | Option_Some (Result_Ok (v)) => - match Option_Some (t_Add_f_add (v) (1)) with + match Option_Some (f_add (v) (1)) with | Option_Some (1) => Option_Some (0) | _ => @@ -145,7 +145,7 @@ Definition multiple_guards (x : t_Option ((t_Result ((t_i32)) ((t_i32))))) : t_i Definition if_guard (x : t_Option ((t_i32))) : t_i32 := match match x with | Option_Some (v) => - match t_PartialOrd_f_gt (v) (0) with + match f_gt (v) (0) with | true => Option_Some (v) | _ => diff --git a/test-harness/src/snapshots/toolchain__include-flag into-coq.snap b/test-harness/src/snapshots/toolchain__include-flag into-coq.snap index 04abbc64e..5217515b8 100644 --- a/test-harness/src/snapshots/toolchain__include-flag into-coq.snap +++ b/test-harness/src/snapshots/toolchain__include-flag into-coq.snap @@ -58,7 +58,7 @@ Class t_Trait `{v_Self : Type} : Type := Arguments t_Trait:clear implicits. Arguments t_Trait (_). -Instance t_Trait_254780795 : t_Trait ((t_Foo)) := +Instance t_Trait_629521404 : t_Trait ((t_Foo)) := { }. diff --git a/test-harness/src/snapshots/toolchain__include-flag into-fstar.snap b/test-harness/src/snapshots/toolchain__include-flag into-fstar.snap index de9402027..81212e6dd 100644 --- a/test-harness/src/snapshots/toolchain__include-flag into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__include-flag into-fstar.snap @@ -37,7 +37,7 @@ type t_Foo = | Foo : t_Foo class t_Trait (v_Self: Type0) = { __marker_trait_t_Trait:Prims.unit } [@@ FStar.Tactics.Typeclasses.tcinstance] -let impl_Trait_for_Foo: t_Trait t_Foo = { __marker_trait = () } +let impl: t_Trait t_Foo = { __marker_trait = () } /// Indirect dependencies let main_a_a (_: Prims.unit) : Prims.unit = () diff --git a/test-harness/src/snapshots/toolchain__interface-only into-fstar.snap b/test-harness/src/snapshots/toolchain__interface-only into-fstar.snap index 555b84045..360a36c08 100644 --- a/test-harness/src/snapshots/toolchain__interface-only into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__interface-only into-fstar.snap @@ -68,9 +68,9 @@ val impl_1': Core.Convert.t_From t_Bar u8 let impl_1 = impl_1' assume -val from__from': u8 -> t_Bar +val f_from__from': u8 -> t_Bar -let from__from = from__from' +let f_from__from = f_from__from' type t_Holder (v_T: Type0) = { f_value:Alloc.Vec.t_Vec v_T Alloc.Alloc.t_Global } @@ -89,7 +89,7 @@ val impl_3': v_SIZE: usize -> Core.Convert.t_From (t_Param v_SIZE) Prims.unit let impl_3 (v_SIZE: usize) = impl_3' v_SIZE assume -val ff_generic': v_X: usize -> #v_U: Type0 -> v__x: v_U -> t_Param v_X +val ff_generic': v_X: usize -> #v_U: Type0 -> e_x: v_U -> t_Param v_X let ff_generic (v_X: usize) (#v_U: Type0) = ff_generic' v_X #v_U diff --git a/test-harness/src/snapshots/toolchain__let-else into-coq.snap b/test-harness/src/snapshots/toolchain__let-else into-coq.snap index 330c601b3..39a7f0186 100644 --- a/test-harness/src/snapshots/toolchain__let-else into-coq.snap +++ b/test-harness/src/snapshots/toolchain__let-else into-coq.snap @@ -54,7 +54,7 @@ Definition let_else (opt : t_Option ((t_u32))) : bool := Definition let_else_different_type (opt : t_Option ((t_u32))) : bool := run (let hoist1 := match opt with | Option_Some (x) => - ControlFlow_Continue (Option_Some (t_Add_f_add (x) (1))) + ControlFlow_Continue (Option_Some (f_add (x) (1))) | _ => ControlFlow_Break (false) end in diff --git a/test-harness/src/snapshots/toolchain__literals into-coq.snap b/test-harness/src/snapshots/toolchain__literals into-coq.snap index 87a42d7cd..6f95144b9 100644 --- a/test-harness/src/snapshots/toolchain__literals into-coq.snap +++ b/test-harness/src/snapshots/toolchain__literals into-coq.snap @@ -47,9 +47,9 @@ Import RecordSetNotations. From Literals Require Import Hax_lib (t_int). Export Hax_lib (t_int). -Definition math_integers (x : t_Int) `{andb (f_gt (x) (impl__Int___unsafe_from_str ("0"%string))) (f_lt (x) (impl__Int___unsafe_from_str ("16"%string))) = true} : t_u8 := +Definition math_integers (x : t_Int) `{andb (f_gt (x) (impl_Int__e_unsafe_from_str ("0"%string))) (f_lt (x) (impl_Int__e_unsafe_from_str ("16"%string))) = true} : t_u8 := let _ : t_Int := f_lift (3) in - let _ := f_gt (impl__Int___unsafe_from_str ("-340282366920938463463374607431768211455000"%string)) (impl__Int___unsafe_from_str ("340282366920938463463374607431768211455000"%string)) in + let _ := f_gt (impl_Int__e_unsafe_from_str ("-340282366920938463463374607431768211455000"%string)) (impl_Int__e_unsafe_from_str ("340282366920938463463374607431768211455000"%string)) in let _ := f_lt (x) (x) in let _ := f_ge (x) (x) in let _ := f_le (x) (x) in @@ -59,17 +59,17 @@ Definition math_integers (x : t_Int) `{andb (f_gt (x) (impl__Int___unsafe_from_s let _ := f_sub (x) (x) in let _ := f_mul (x) (x) in let _ := f_div (x) (x) in - let _ : t_i16 := impl__Int__to_i16 (x) in - let _ : t_i32 := impl__Int__to_i32 (x) in - let _ : t_i64 := impl__Int__to_i64 (x) in - let _ : t_i128 := impl__Int__to_i128 (x) in - let _ : t_isize := impl__Int__to_isize (x) in - let _ : t_u16 := impl__Int__to_u16 (x) in - let _ : t_u32 := impl__Int__to_u32 (x) in - let _ : t_u64 := impl__Int__to_u64 (x) in - let _ : t_u128 := impl__Int__to_u128 (x) in - let _ : t_usize := impl__Int__to_usize (x) in - impl__Int__to_u8 (f_add (x) (f_mul (x) (x))). + let _ : t_i16 := impl_Int__to_i16 (x) in + let _ : t_i32 := impl_Int__to_i32 (x) in + let _ : t_i64 := impl_Int__to_i64 (x) in + let _ : t_i128 := impl_Int__to_i128 (x) in + let _ : t_isize := impl_Int__to_isize (x) in + let _ : t_u16 := impl_Int__to_u16 (x) in + let _ : t_u32 := impl_Int__to_u32 (x) in + let _ : t_u64 := impl_Int__to_u64 (x) in + let _ : t_u128 := impl_Int__to_u128 (x) in + let _ : t_usize := impl_Int__to_usize (x) in + impl_Int__to_u8 (f_add (x) (f_mul (x) (x))). Definition panic_with_msg (_ : unit) : unit := never_to_any (panic_fmt (impl_2__new_const (["with msg"%string]))). @@ -109,7 +109,7 @@ Definition patterns (_ : unit) : unit := tt end in let _ := match ("hello"%string,(123,["a"%string; "b"%string])) with - | ("hello"%string,(123,v__todo)) => + | ("hello"%string,(123,e_todo)) => tt | _ => tt @@ -123,14 +123,14 @@ Definition patterns (_ : unit) : unit := tt. Definition casts (x8 : t_u8) (x16 : t_u16) (x32 : t_u32) (x64 : t_u64) (xs : t_usize) : unit := - let _ : t_u64 := t_Add_f_add (t_Add_f_add (t_Add_f_add (t_Add_f_add (cast (x8)) (cast (x16))) (cast (x32))) (x64)) (cast (xs)) in - let _ : t_u32 := t_Add_f_add (t_Add_f_add (t_Add_f_add (t_Add_f_add (cast (x8)) (cast (x16))) (x32)) (cast (x64))) (cast (xs)) in - let _ : t_u16 := t_Add_f_add (t_Add_f_add (t_Add_f_add (t_Add_f_add (cast (x8)) (x16)) (cast (x32))) (cast (x64))) (cast (xs)) in - let _ : t_u8 := t_Add_f_add (t_Add_f_add (t_Add_f_add (t_Add_f_add (x8) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in - let _ : t_i64 := t_Add_f_add (t_Add_f_add (t_Add_f_add (t_Add_f_add (cast (x8)) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in - let _ : t_i32 := t_Add_f_add (t_Add_f_add (t_Add_f_add (t_Add_f_add (cast (x8)) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in - let _ : t_i16 := t_Add_f_add (t_Add_f_add (t_Add_f_add (t_Add_f_add (cast (x8)) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in - let _ : t_i8 := t_Add_f_add (t_Add_f_add (t_Add_f_add (t_Add_f_add (cast (x8)) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in + let _ : t_u64 := f_add (f_add (f_add (f_add (cast (x8)) (cast (x16))) (cast (x32))) (x64)) (cast (xs)) in + let _ : t_u32 := f_add (f_add (f_add (f_add (cast (x8)) (cast (x16))) (x32)) (cast (x64))) (cast (xs)) in + let _ : t_u16 := f_add (f_add (f_add (f_add (cast (x8)) (x16)) (cast (x32))) (cast (x64))) (cast (xs)) in + let _ : t_u8 := f_add (f_add (f_add (f_add (x8) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in + let _ : t_i64 := f_add (f_add (f_add (f_add (cast (x8)) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in + let _ : t_i32 := f_add (f_add (f_add (f_add (cast (x8)) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in + let _ : t_i16 := f_add (f_add (f_add (f_add (cast (x8)) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in + let _ : t_i8 := f_add (f_add (f_add (f_add (cast (x8)) (cast (x16))) (cast (x32))) (cast (x64))) (cast (xs)) in tt. Definition empty_array (_ : unit) : unit := diff --git a/test-harness/src/snapshots/toolchain__literals into-fstar.snap b/test-harness/src/snapshots/toolchain__literals into-fstar.snap index ad1421b02..129cc883a 100644 --- a/test-harness/src/snapshots/toolchain__literals into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__literals into-fstar.snap @@ -51,17 +51,17 @@ let math_integers (x: Hax_lib.Int.t_Int) let _:Hax_lib.Int.t_Int = x - x in let _:Hax_lib.Int.t_Int = x * x in let _:Hax_lib.Int.t_Int = x / x in - let _:i16 = Hax_lib.Int.impl__Int__to_i16 x in - let _:i32 = Hax_lib.Int.impl__Int__to_i32 x in - let _:i64 = Hax_lib.Int.impl__Int__to_i64 x in - let _:i128 = Hax_lib.Int.impl__Int__to_i128 x in - let _:isize = Hax_lib.Int.impl__Int__to_isize x in - let _:u16 = Hax_lib.Int.impl__Int__to_u16 x in - let _:u32 = Hax_lib.Int.impl__Int__to_u32 x in - let _:u64 = Hax_lib.Int.impl__Int__to_u64 x in - let _:u128 = Hax_lib.Int.impl__Int__to_u128 x in - let _:usize = Hax_lib.Int.impl__Int__to_usize x in - Hax_lib.Int.impl__Int__to_u8 (x + (x * x <: Hax_lib.Int.t_Int) <: Hax_lib.Int.t_Int) + let _:i16 = Hax_lib.Int.impl_Int__to_i16 x in + let _:i32 = Hax_lib.Int.impl_Int__to_i32 x in + let _:i64 = Hax_lib.Int.impl_Int__to_i64 x in + let _:i128 = Hax_lib.Int.impl_Int__to_i128 x in + let _:isize = Hax_lib.Int.impl_Int__to_isize x in + let _:u16 = Hax_lib.Int.impl_Int__to_u16 x in + let _:u32 = Hax_lib.Int.impl_Int__to_u32 x in + let _:u64 = Hax_lib.Int.impl_Int__to_u64 x in + let _:u128 = Hax_lib.Int.impl_Int__to_u128 x in + let _:usize = Hax_lib.Int.impl_Int__to_usize x in + Hax_lib.Int.impl_Int__to_u8 (x + (x * x <: Hax_lib.Int.t_Int) <: Hax_lib.Int.t_Int) let panic_with_msg (_: Prims.unit) : Prims.unit = Rust_primitives.Hax.never_to_any (Core.Panicking.panic_fmt (Core.Fmt.impl_2__new_const (mk_usize 1 @@ -122,7 +122,7 @@ let patterns (_: Prims.unit) : Prims.unit = <: (string & (i32 & t_Array string (mk_usize 2))) with - | "hello", (Rust_primitives.Integers.MkInt 123, v__todo) -> () <: Prims.unit + | "hello", (Rust_primitives.Integers.MkInt 123, e_todo) -> () <: Prims.unit | _ -> () <: Prims.unit in let _:Prims.unit = diff --git a/test-harness/src/snapshots/toolchain__loops into-fstar.snap b/test-harness/src/snapshots/toolchain__loops into-fstar.snap index 463b0849a..c713c83d4 100644 --- a/test-harness/src/snapshots/toolchain__loops into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__loops into-fstar.snap @@ -140,7 +140,7 @@ let double_sum2 (_: Prims.unit) : i32 = let double_sum_return (v: t_Slice i32) : i32 = let sum:i32 = mk_i32 0 in match - Rust_primitives.Hax.f_fold_return (Core.Iter.Traits.Collect.f_into_iter #(t_Slice i32) + Rust_primitives.Hax.Folds.fold_return (Core.Iter.Traits.Collect.f_into_iter #(t_Slice i32) #FStar.Tactics.Typeclasses.solve v <: @@ -173,7 +173,7 @@ let double_sum2_return (v: t_Slice i32) : i32 = let sum:i32 = mk_i32 0 in let sum2:i32 = mk_i32 0 in match - Rust_primitives.Hax.f_fold_return (Core.Iter.Traits.Collect.f_into_iter #(t_Slice i32) + Rust_primitives.Hax.Folds.fold_return (Core.Iter.Traits.Collect.f_into_iter #(t_Slice i32) #FStar.Tactics.Typeclasses.solve v <: @@ -205,7 +205,7 @@ let double_sum2_return (v: t_Slice i32) : i32 = let bigger_power_2_ (x: i32) : i32 = let pow:i32 = mk_i32 1 in - Rust_primitives.f_while_loop_cf (fun pow -> + Rust_primitives.Hax.while_loop_cf (fun pow -> let pow:i32 = pow in pow <. mk_i32 1000000 <: bool) pow @@ -231,7 +231,7 @@ let bigger_power_2_ (x: i32) : i32 = type t_M = { f_m:Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global } -let impl__M__decoded_message (self: t_M) +let impl_M__decoded_message (self: t_M) : Core.Option.t_Option (Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global) = match Rust_primitives.Hax.Folds.fold_range_return (mk_usize 0) @@ -788,7 +788,7 @@ open FStar.Mul let f (_: Prims.unit) : u8 = let x:u8 = mk_u8 0 in let x:u8 = - Rust_primitives.f_while_loop (fun x -> + Rust_primitives.Hax.while_loop (fun x -> let x:u8 = x in x <. mk_u8 10 <: bool) x diff --git a/test-harness/src/snapshots/toolchain__mut-ref-functionalization into-fstar.snap b/test-harness/src/snapshots/toolchain__mut-ref-functionalization into-fstar.snap index 549b7fce7..ac5dff563 100644 --- a/test-harness/src/snapshots/toolchain__mut-ref-functionalization into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__mut-ref-functionalization into-fstar.snap @@ -61,7 +61,7 @@ let foo (lhs rhs: t_S) : t_S = in lhs -let impl__S__update (self: t_S) (x: u8) : t_S = +let impl_S__update (self: t_S) (x: u8) : t_S = let self:t_S = { self with diff --git a/test-harness/src/snapshots/toolchain__naming into-fstar.snap b/test-harness/src/snapshots/toolchain__naming into-fstar.snap index 7db561b18..7d3a1ea1a 100644 --- a/test-harness/src/snapshots/toolchain__naming into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__naming into-fstar.snap @@ -34,7 +34,7 @@ open FStar.Mul let debug (label value: u32) : Prims.unit = let _:Prims.unit = - Std.Io.Stdio.v__print (Core.Fmt.impl_2__new_v1 (mk_usize 3) + Std.Io.Stdio.e_print (Core.Fmt.impl_2__new_v1 (mk_usize 3) (mk_usize 2) (let list = ["["; "] a="; "\n"] in FStar.Pervasives.assert_norm (Prims.eq2 (List.Tot.length list) 3); @@ -80,14 +80,6 @@ let ff_expand (_: Prims.unit) : Prims.unit = let _:Prims.unit = debug (mk_u32 1) a in debug (mk_u32 0) a ''' -"Naming.F.G.Impl_1.G.Hello.fst" = ''' -module Naming.F.G.Impl_1.G.Hello -#set-options "--fuel 0 --ifuel 1 --z3rlimit 15" -open Core -open FStar.Mul - -let h (_: Prims.unit) : Prims.unit = () -''' "Naming.fst" = ''' module Naming #set-options "--fuel 0 --ifuel 1 --z3rlimit 15" @@ -109,27 +101,29 @@ type t_C = { f_x:usize } type t_X = | X : t_X let mk_c (_: Prims.unit) : t_C = - let _:t_Foo = Foo_B ({ Naming.Foo.f_x = mk_usize 3 }) <: t_Foo in + let _:t_Foo = Foo_B ({ f_x = mk_usize 3 }) <: t_Foo in let _:t_X = X <: t_X in { f_x = mk_usize 3 } <: t_C -let impl__Foo__f (self: t_Foo) : t_Foo = Foo_A <: t_Foo +let impl_Foo__f (self: t_Foo) : t_Foo = Foo_A <: t_Foo -let impl__B__f (self: t_B) : t_B = B <: t_B +let impl_B__f (self: t_B) : t_B = B <: t_B type t_Foobar = { f_a:t_Foo } -let ff__g (_: Prims.unit) : Prims.unit = () +let f__g (_: Prims.unit) : Prims.unit = () + +let f__g__impl_B__g (self: t_B) : usize = mk_usize 0 -let ff__g__impl__g (self: t_B) : usize = mk_usize 0 +type f__g__impl_B__g__t_Foo = + | C_f__g__impl_B__g__Foo_A : f__g__impl_B__g__t_Foo + | C_f__g__impl_B__g__Foo_B { f__g__impl_B__g__f_x:usize }: f__g__impl_B__g__t_Foo -type t_f__g__impl__g__Foo = - | C_f__g__impl__g__Foo_A : t_f__g__impl__g__Foo - | C_f__g__impl__g__Foo_B { f_x:usize }: t_f__g__impl__g__Foo +let f__g__impl_Foo__g (self: t_Foo) : usize = mk_usize 1 -let ff__g__impl_1__g (self: t_Foo) : usize = mk_usize 1 +let f (x: t_Foobar) : usize = f__g__impl_Foo__g x.f_a -let f (x: t_Foobar) : usize = ff__g__impl_1__g x.f_a +let f__g__impl_Foo__g__t_hello__h (_: Prims.unit) : Prims.unit = () let reserved_names (v_val v_noeq v_of: u8) : u8 = (v_val +! v_noeq <: u8) +! v_of @@ -146,13 +140,13 @@ let impl_T1_for_tuple_Foo_u8: t_T1 (t_Foo & u8) = { __marker_trait = () } class t_T2_for_a (v_Self: Type0) = { __marker_trait_t_T2_for_a:Prims.unit } [@@ FStar.Tactics.Typeclasses.tcinstance] -let impl_T2_e_for_a_for_Arity1_of_tuple_Foo_u8: t_T2_for_a (t_Arity1 (t_Foo & u8)) = +let impl_T2_ee_for_a_for_Arity1_of_tuple_Foo_u8: t_T2_for_a (t_Arity1 (t_Foo & u8)) = { __marker_trait = () } -class t_T3_e_for_a (v_Self: Type0) = { __marker_trait_t_T3_e_for_a:Prims.unit } +class t_T3_ee_for_a (v_Self: Type0) = { __marker_trait_t_T3_ee_for_a:Prims.unit } [@@ FStar.Tactics.Typeclasses.tcinstance] -let impl_T3_e_e_for_a_for_Foo: t_T3_e_for_a t_Foo = { __marker_trait = () } +let impl_T3_ee_e_for_a_for_Foo: t_T3_ee_for_a t_Foo = { __marker_trait = () } type t_StructA = { f_a:usize } diff --git a/test-harness/src/snapshots/toolchain__reordering into-coq.snap b/test-harness/src/snapshots/toolchain__reordering into-coq.snap index 9d1c84ae2..87b55e555 100644 --- a/test-harness/src/snapshots/toolchain__reordering into-coq.snap +++ b/test-harness/src/snapshots/toolchain__reordering into-coq.snap @@ -78,10 +78,6 @@ Definition t_Foo_cast_to_repr (x : t_Foo) : t_isize := | Foo_B => 1 end. - -(* NotImplementedYet *) - -(* NotImplementedYet *) ''' "Reordering_Independent_cycles.v" = ''' (* File automatically generated by Hacspec *) @@ -96,6 +92,8 @@ Require Import Coq.Floats.Floats. From RecordUpdate Require Import RecordSet. Import RecordSetNotations. +(* NotImplementedYet *) + Definition c (_ : unit) : unit := a (tt). @@ -121,6 +119,8 @@ Require Import Coq.Floats.Floats. From RecordUpdate Require Import RecordSet. Import RecordSetNotations. +(* NotImplementedYet *) + Definition g (_ : unit) : unit := f (tt). diff --git a/test-harness/src/snapshots/toolchain__reordering into-ssprove.snap b/test-harness/src/snapshots/toolchain__reordering into-ssprove.snap index ff7d30d50..85d01c8dd 100644 --- a/test-harness/src/snapshots/toolchain__reordering into-ssprove.snap +++ b/test-harness/src/snapshots/toolchain__reordering into-ssprove.snap @@ -55,6 +55,45 @@ Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. (*Not implemented yet? todo(item)*) +Equations g {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + g _ := + solve_lift (f (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations f {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + f _ := + solve_lift (g (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations ff_2_ {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + ff_2_ _ := + solve_lift (f (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations c {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + c _ := + solve_lift (a (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations a {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + a _ := + solve_lift (c (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations d {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + d _ := + solve_lift (b (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations b {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + b _ := + solve_lift (d (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + Equations no_dependency_1_ {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := no_dependency_1_ _ := solve_lift (ret_both (tt : 'unit)) : both L1 I1 'unit. @@ -111,10 +150,6 @@ Equations t_Foo_cast_to_repr {L1 : {fset Location}} {I1 : Interface} (x : both L solve_lift (ret_both (1 : uint_size)) end : both L1 I1 uint_size. Fail Next Obligation. - -(*Not implemented yet? todo(item)*) - -(*Not implemented yet? todo(item)*) ''' "Reordering_Independent_cycles.v" = ''' (* File automatically generated by Hacspec *) @@ -143,6 +178,25 @@ Import choice.Choice.Exports. Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. +(*Not implemented yet? todo(item)*) + +Equations g {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + g _ := + solve_lift (f (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations f {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + f _ := + solve_lift (g (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations ff_2_ {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + ff_2_ _ := + solve_lift (f (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + Equations c {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := c _ := solve_lift (a (ret_both (tt : 'unit))) : both L1 I1 'unit. @@ -162,6 +216,65 @@ Equations b {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : bot b _ := solve_lift (d (ret_both (tt : 'unit))) : both L1 I1 'unit. Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations no_dependency_1_ {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + no_dependency_1_ _ := + solve_lift (ret_both (tt : 'unit)) : both L1 I1 'unit. +Fail Next Obligation. + +Equations no_dependency_2_ {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + no_dependency_2_ _ := + solve_lift (ret_both (tt : 'unit)) : both L1 I1 'unit. +Fail Next Obligation. + +Definition t_Foo : choice_type := + ('unit ∐ 'unit). +Notation "'Foo_A_case'" := (inl tt) (at level 100). +Equations Foo_A {L : {fset Location}} {I : Interface} : both L I t_Foo := + Foo_A := + solve_lift (ret_both (inl (tt : 'unit) : t_Foo)) : both L I t_Foo. +Fail Next Obligation. +Notation "'Foo_B_case'" := (inr tt) (at level 100). +Equations Foo_B {L : {fset Location}} {I : Interface} : both L I t_Foo := + Foo_B := + solve_lift (ret_both (inr (tt : 'unit) : t_Foo)) : both L I t_Foo. +Fail Next Obligation. + +Equations f {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 int32) : both L1 I1 t_Foo := + f _ := + Foo_A : both L1 I1 t_Foo. +Fail Next Obligation. + +Definition t_Bar : choice_type := + (t_Foo). +Equations 0 {L : {fset Location}} {I : Interface} (s : both L I t_Bar) : both L I t_Foo := + 0 s := + bind_both s (fun x => + solve_lift (ret_both (x : t_Foo))) : both L I t_Foo. +Fail Next Obligation. +Equations Build_t_Bar {L0 : {fset Location}} {I0 : Interface} {0 : both L0 I0 t_Foo} : both L0 I0 (t_Bar) := + Build_t_Bar := + bind_both 0 (fun 0 => + solve_lift (ret_both ((0) : (t_Bar)))) : both L0 I0 (t_Bar). +Fail Next Obligation. +Notation "'Build_t_Bar' '[' x ']' '(' '0' ':=' y ')'" := (Build_t_Bar (0 := y)). + +Equations g {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 t_Bar := + g _ := + Bar (solve_lift (f (ret_both (32 : int32)))) : both L1 I1 t_Bar. +Fail Next Obligation. + +Equations t_Foo_cast_to_repr {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 t_Foo) : both L1 I1 uint_size := + t_Foo_cast_to_repr x := + matchb x with + | Foo_A_case => + solve_lift (ret_both (0 : uint_size)) + | Foo_B_case => + solve_lift (ret_both (1 : uint_size)) + end : both L1 I1 uint_size. +Fail Next Obligation. ''' "Reordering_Mut_rec.v" = ''' (* File automatically generated by Hacspec *) @@ -190,6 +303,8 @@ Import choice.Choice.Exports. Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. +(*Not implemented yet? todo(item)*) + Equations g {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := g _ := solve_lift (f (ret_both (tt : 'unit))) : both L1 I1 'unit. @@ -204,4 +319,85 @@ Equations ff_2_ {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : ff_2_ _ := solve_lift (f (ret_both (tt : 'unit))) : both L1 I1 'unit. Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations c {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + c _ := + solve_lift (a (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations a {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + a _ := + solve_lift (c (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations d {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + d _ := + solve_lift (b (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +Equations b {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + b _ := + solve_lift (d (ret_both (tt : 'unit))) : both L1 I1 'unit. +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations no_dependency_1_ {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + no_dependency_1_ _ := + solve_lift (ret_both (tt : 'unit)) : both L1 I1 'unit. +Fail Next Obligation. + +Equations no_dependency_2_ {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 'unit := + no_dependency_2_ _ := + solve_lift (ret_both (tt : 'unit)) : both L1 I1 'unit. +Fail Next Obligation. + +Definition t_Foo : choice_type := + ('unit ∐ 'unit). +Notation "'Foo_A_case'" := (inl tt) (at level 100). +Equations Foo_A {L : {fset Location}} {I : Interface} : both L I t_Foo := + Foo_A := + solve_lift (ret_both (inl (tt : 'unit) : t_Foo)) : both L I t_Foo. +Fail Next Obligation. +Notation "'Foo_B_case'" := (inr tt) (at level 100). +Equations Foo_B {L : {fset Location}} {I : Interface} : both L I t_Foo := + Foo_B := + solve_lift (ret_both (inr (tt : 'unit) : t_Foo)) : both L I t_Foo. +Fail Next Obligation. + +Equations f {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 int32) : both L1 I1 t_Foo := + f _ := + Foo_A : both L1 I1 t_Foo. +Fail Next Obligation. + +Definition t_Bar : choice_type := + (t_Foo). +Equations 0 {L : {fset Location}} {I : Interface} (s : both L I t_Bar) : both L I t_Foo := + 0 s := + bind_both s (fun x => + solve_lift (ret_both (x : t_Foo))) : both L I t_Foo. +Fail Next Obligation. +Equations Build_t_Bar {L0 : {fset Location}} {I0 : Interface} {0 : both L0 I0 t_Foo} : both L0 I0 (t_Bar) := + Build_t_Bar := + bind_both 0 (fun 0 => + solve_lift (ret_both ((0) : (t_Bar)))) : both L0 I0 (t_Bar). +Fail Next Obligation. +Notation "'Build_t_Bar' '[' x ']' '(' '0' ':=' y ')'" := (Build_t_Bar (0 := y)). + +Equations g {L1 : {fset Location}} {I1 : Interface} (_ : both L1 I1 'unit) : both L1 I1 t_Bar := + g _ := + Bar (solve_lift (f (ret_both (32 : int32)))) : both L1 I1 t_Bar. +Fail Next Obligation. + +Equations t_Foo_cast_to_repr {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 t_Foo) : both L1 I1 uint_size := + t_Foo_cast_to_repr x := + matchb x with + | Foo_A_case => + solve_lift (ret_both (0 : uint_size)) + | Foo_B_case => + solve_lift (ret_both (1 : uint_size)) + end : both L1 I1 uint_size. +Fail Next Obligation. ''' diff --git a/test-harness/src/snapshots/toolchain__side-effects into-fstar.snap b/test-harness/src/snapshots/toolchain__side-effects into-fstar.snap index 6ee83294e..b56fb65f0 100644 --- a/test-harness/src/snapshots/toolchain__side-effects into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__side-effects into-fstar.snap @@ -114,17 +114,17 @@ open FStar.Mul /// Helper function let add3 (x y z: u32) : u32 = - Core.Num.impl__u32__wrapping_add (Core.Num.impl__u32__wrapping_add x y <: u32) z + Core.Num.impl_u32__wrapping_add (Core.Num.impl_u32__wrapping_add x y <: u32) z /// Exercise local mutation with control flow and loops let local_mutation (x: u32) : u32 = let y:u32 = mk_u32 0 in - let x:u32 = Core.Num.impl__u32__wrapping_add x (mk_u32 1) in + let x:u32 = Core.Num.impl_u32__wrapping_add x (mk_u32 1) in if x >. mk_u32 3 then - let x:u32 = Core.Num.impl__u32__wrapping_sub x (mk_u32 3) in + let x:u32 = Core.Num.impl_u32__wrapping_sub x (mk_u32 3) in let y:u32 = x /! mk_u32 2 in - let y:u32 = Core.Num.impl__u32__wrapping_add y (mk_u32 2) in + let y:u32 = Core.Num.impl_u32__wrapping_add y (mk_u32 2) in let y:u32 = Core.Iter.Traits.Iterator.f_fold (Core.Iter.Traits.Collect.f_into_iter #(Core.Ops.Range.t_Range u32) @@ -138,24 +138,24 @@ let local_mutation (x: u32) : u32 = (fun y i -> let y:u32 = y in let i:u32 = i in - Core.Num.impl__u32__wrapping_add x i <: u32) + Core.Num.impl_u32__wrapping_add x i <: u32) in - Core.Num.impl__u32__wrapping_add x y + Core.Num.impl_u32__wrapping_add x y else let (x, y), hoist7:((u32 & u32) & u32) = match x <: u32 with | Rust_primitives.Integers.MkInt 12 -> - let y:u32 = Core.Num.impl__u32__wrapping_add x y in + let y:u32 = Core.Num.impl_u32__wrapping_add x y in (x, y <: (u32 & u32)), mk_u32 3 <: ((u32 & u32) & u32) | Rust_primitives.Integers.MkInt 13 -> - let x:u32 = Core.Num.impl__u32__wrapping_add x (mk_u32 1) in - (x, y <: (u32 & u32)), add3 x (Core.Num.impl__u32__wrapping_add (mk_u32 123) x <: u32) x + let x:u32 = Core.Num.impl_u32__wrapping_add x (mk_u32 1) in + (x, y <: (u32 & u32)), add3 x (Core.Num.impl_u32__wrapping_add (mk_u32 123) x <: u32) x <: ((u32 & u32) & u32) | _ -> (x, y <: (u32 & u32)), mk_u32 0 <: ((u32 & u32) & u32) in let x:u32 = hoist7 in - Core.Num.impl__u32__wrapping_add x y + Core.Num.impl_u32__wrapping_add x y /// Exercise early returns with control flow and loops let early_returns (x: u32) : u32 = @@ -168,15 +168,13 @@ let early_returns (x: u32) : u32 = | true -> mk_u32 34 | _ -> let x, hoist11:(u32 & u32) = x, mk_u32 3 <: (u32 & u32) in - Core.Num.impl__u32__wrapping_add (Core.Num.impl__u32__wrapping_add (mk_u32 123) hoist11 - <: - u32) + Core.Num.impl_u32__wrapping_add (Core.Num.impl_u32__wrapping_add (mk_u32 123) hoist11 <: u32 + ) x else let x:u32 = x +! mk_u32 9 in let x, hoist11:(u32 & u32) = x, x +! mk_u32 1 <: (u32 & u32) in - Core.Num.impl__u32__wrapping_add (Core.Num.impl__u32__wrapping_add (mk_u32 123) hoist11 <: u32 - ) + Core.Num.impl_u32__wrapping_add (Core.Num.impl_u32__wrapping_add (mk_u32 123) hoist11 <: u32) x let simplifiable_return (c1 c2 c3: bool) : i32 = @@ -230,7 +228,7 @@ let options (x y: Core.Option.t_Option u8) (z: Core.Option.t_Option u64) : Core. match x <: Core.Option.t_Option u8 with | Core.Option.Option_Some hoist23 -> (match - Core.Option.Option_Some (Core.Num.impl__u8__wrapping_add hoist23 (mk_u8 3)) + Core.Option.Option_Some (Core.Num.impl_u8__wrapping_add hoist23 (mk_u8 3)) <: Core.Option.t_Option u8 with @@ -245,7 +243,7 @@ let options (x y: Core.Option.t_Option u8) (z: Core.Option.t_Option u64) : Core. (match y <: Core.Option.t_Option u8 with | Core.Option.Option_Some hoist31 -> Core.Option.Option_Some - (Core.Num.impl__u8__wrapping_add (Core.Num.impl__u8__wrapping_add v + (Core.Num.impl_u8__wrapping_add (Core.Num.impl_u8__wrapping_add v hoist30 <: u8) @@ -268,7 +266,7 @@ let options (x y: Core.Option.t_Option u8) (z: Core.Option.t_Option u64) : Core. (match y <: Core.Option.t_Option u8 with | Core.Option.Option_Some hoist31 -> Core.Option.Option_Some - (Core.Num.impl__u8__wrapping_add (Core.Num.impl__u8__wrapping_add v + (Core.Num.impl_u8__wrapping_add (Core.Num.impl_u8__wrapping_add v hoist30 <: u8) @@ -287,7 +285,7 @@ let options (x y: Core.Option.t_Option u8) (z: Core.Option.t_Option u64) : Core. (match y <: Core.Option.t_Option u8 with | Core.Option.Option_Some hoist31 -> Core.Option.Option_Some - (Core.Num.impl__u8__wrapping_add (Core.Num.impl__u8__wrapping_add v hoist30 + (Core.Num.impl_u8__wrapping_add (Core.Num.impl_u8__wrapping_add v hoist30 <: u8) hoist31) @@ -304,7 +302,7 @@ let options (x y: Core.Option.t_Option u8) (z: Core.Option.t_Option u64) : Core. (match y <: Core.Option.t_Option u8 with | Core.Option.Option_Some hoist25 -> (match - Core.Option.Option_Some (Core.Num.impl__u8__wrapping_add hoist26 hoist25) + Core.Option.Option_Some (Core.Num.impl_u8__wrapping_add hoist26 hoist25) <: Core.Option.t_Option u8 with @@ -319,7 +317,7 @@ let options (x y: Core.Option.t_Option u8) (z: Core.Option.t_Option u64) : Core. (match y <: Core.Option.t_Option u8 with | Core.Option.Option_Some hoist31 -> Core.Option.Option_Some - (Core.Num.impl__u8__wrapping_add (Core.Num.impl__u8__wrapping_add v + (Core.Num.impl_u8__wrapping_add (Core.Num.impl_u8__wrapping_add v hoist30 <: u8) @@ -343,7 +341,7 @@ let options (x y: Core.Option.t_Option u8) (z: Core.Option.t_Option u64) : Core. (match y <: Core.Option.t_Option u8 with | Core.Option.Option_Some hoist31 -> Core.Option.Option_Some - (Core.Num.impl__u8__wrapping_add (Core.Num.impl__u8__wrapping_add v + (Core.Num.impl_u8__wrapping_add (Core.Num.impl_u8__wrapping_add v hoist30 <: u8) @@ -363,7 +361,7 @@ let options (x y: Core.Option.t_Option u8) (z: Core.Option.t_Option u64) : Core. (match y <: Core.Option.t_Option u8 with | Core.Option.Option_Some hoist31 -> Core.Option.Option_Some - (Core.Num.impl__u8__wrapping_add (Core.Num.impl__u8__wrapping_add v + (Core.Num.impl_u8__wrapping_add (Core.Num.impl_u8__wrapping_add v hoist30 <: u8) @@ -384,14 +382,14 @@ let question_mark (x: u32) : Core.Result.t_Result u32 u32 = if x >. mk_u32 40 then let y:u32 = mk_u32 0 in - let x:u32 = Core.Num.impl__u32__wrapping_add x (mk_u32 3) in - let y:u32 = Core.Num.impl__u32__wrapping_add x y in - let x:u32 = Core.Num.impl__u32__wrapping_add x y in + let x:u32 = Core.Num.impl_u32__wrapping_add x (mk_u32 3) in + let y:u32 = Core.Num.impl_u32__wrapping_add x y in + let x:u32 = Core.Num.impl_u32__wrapping_add x y in if x >. mk_u32 90 then match Core.Result.Result_Err (mk_u8 12) <: Core.Result.t_Result Prims.unit u8 with | Core.Result.Result_Ok ok -> - Core.Result.Result_Ok (Core.Num.impl__u32__wrapping_add (mk_u32 3) x) + Core.Result.Result_Ok (Core.Num.impl_u32__wrapping_add (mk_u32 3) x) <: Core.Result.t_Result u32 u32 | Core.Result.Result_Err err -> @@ -399,11 +397,11 @@ let question_mark (x: u32) : Core.Result.t_Result u32 u32 = <: Core.Result.t_Result u32 u32 else - Core.Result.Result_Ok (Core.Num.impl__u32__wrapping_add (mk_u32 3) x) + Core.Result.Result_Ok (Core.Num.impl_u32__wrapping_add (mk_u32 3) x) <: Core.Result.t_Result u32 u32 else - Core.Result.Result_Ok (Core.Num.impl__u32__wrapping_add (mk_u32 3) x) + Core.Result.Result_Ok (Core.Num.impl_u32__wrapping_add (mk_u32 3) x) <: Core.Result.t_Result u32 u32 diff --git a/test-harness/src/snapshots/toolchain__side-effects into-ssprove.snap b/test-harness/src/snapshots/toolchain__side-effects into-ssprove.snap index 766cd6165..4148c9cf8 100644 --- a/test-harness/src/snapshots/toolchain__side-effects into-ssprove.snap +++ b/test-harness/src/snapshots/toolchain__side-effects into-ssprove.snap @@ -56,16 +56,63 @@ Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. (*Not implemented yet? todo(item)*) +Equations other_fun {L1 : {fset Location}} {I1 : Interface} (rng : both L1 I1 int8) : both L1 I1 (int8 × t_Result 'unit 'unit) := + other_fun rng := + letb hax_temp_output := Result_Ok (ret_both (tt : 'unit)) in + solve_lift (prod_b (rng,hax_temp_output)) : both L1 I1 (int8 × t_Result 'unit 'unit). +Fail Next Obligation. + +Equations fun {L1 : {fset Location}} {I1 : Interface} (rng : both L1 I1 int8) : both L1 I1 (int8 × t_Result 'unit 'unit) := + fun rng := + solve_lift (run (letb '(tmp0,out) := other_fun rng in + letb _ := assign todo(term) in + letb hoist43 := out in + letb hoist44 := f_branch hoist43 in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist45 := matchb hoist44 with + | ControlFlow_Break_case residual => + letb residual := ret_both ((residual) : (t_Result t_Infallible 'unit)) in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist42 := ControlFlow_Break (prod_b (rng,f_from_residual residual)) in + ControlFlow_Continue (solve_lift (never_to_any hoist42)) + | ControlFlow_Continue_case val => + letb val := ret_both ((val) : ('unit)) in + ControlFlow_Continue (solve_lift val) + end in + letb hoist46 := Result_Ok hoist45 in + letb hoist47 := prod_b (rng,hoist46) in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist48 := ControlFlow_Break hoist47 in + ControlFlow_Continue (letb hax_temp_output := never_to_any hoist48 in + prod_b (rng,hax_temp_output)))) : both L1 I1 (int8 × t_Result 'unit 'unit). +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Class t_MyFrom (Self : choice_type) := { + f_my_from_loc : {fset Location} ; + f_my_from : (forall {L1 I1}, both L1 I1 v_T -> both (L1 :|: f_my_from_loc) I1 v_Self) ; +}. +Hint Unfold f_my_from_loc. + +#[global] Program Instance int16_t_MyFrom : t_MyFrom int16 int8 := + let f_my_from := fun {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) => solve_lift (cast_int (WS2 := _) x) : both (L1 :|: fset []) I1 int16 in + {| f_my_from_loc := (fset [] : {fset Location}); + f_my_from := (@f_my_from)|}. +Fail Next Obligation. +Hint Unfold int16_t_MyFrom. + +Equations f {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) : both L1 I1 (t_Result int16 int16) := + f x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int16] _ := impl__map_err (Result_Err (ret_both (1 : int8))) f_from in + Result_Ok (Result_Ok (f_my_from x)))) : both L1 I1 (t_Result int16 int16). +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + Equations add3 {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (x : both L1 I1 int32) (y : both L2 I2 int32) (z : both L3 I3 int32) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32 := add3 x y z := - solve_lift (impl__u32__wrapping_add (impl__u32__wrapping_add x y) z) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. + solve_lift (impl_u32__wrapping_add (impl_u32__wrapping_add x y) z) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. Fail Next Obligation. -Definition y_loc : Location := - (int32;0%nat). -Definition y_loc : Location := - (int32;1%nat). -Equations local_mutation {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both (L1 :|: fset [y_loc;y_loc]) I1 int32 := +Equations local_mutation {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 int32 := local_mutation x := letb y loc(y_loc) := ret_both (0 : int32) in letb _ := assign todo(term) in @@ -80,7 +127,7 @@ Equations local_mutation {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 letb _ := foldi_both_list hoist4 (fun i => ssp (fun _ => assign todo(term) : (both (*0*)(L1:|:fset []) (I1) 'unit))) (ret_both (tt : 'unit)) in - impl__u32__wrapping_add x y + impl_u32__wrapping_add x y else letb hoist7 := matchb x with | 12 => letb _ := assign todo(term) in @@ -88,13 +135,13 @@ Equations local_mutation {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 | 13 => letb hoist6 := x in letb _ := assign todo(term) in - letb hoist5 := impl__u32__wrapping_add (ret_both (123 : int32)) x in + letb hoist5 := impl_u32__wrapping_add (ret_both (123 : int32)) x in solve_lift (add3 hoist6 hoist5 x) | _ => solve_lift (ret_both (0 : int32)) end in letb _ := assign todo(term) in - impl__u32__wrapping_add x y) : both (L1 :|: fset [y_loc;y_loc]) I1 int32. + impl_u32__wrapping_add x y) : both L1 I1 int32. Fail Next Obligation. Equations early_returns {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 int32 := @@ -114,15 +161,13 @@ Equations early_returns {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 end else ControlFlow_Continue (letb _ := assign todo(term) in x .+ (ret_both (1 : int32))) in - letb hoist12 := impl__u32__wrapping_add (ret_both (123 : int32)) hoist11 in - letb hoist13 := impl__u32__wrapping_add hoist12 x in + letb hoist12 := impl_u32__wrapping_add (ret_both (123 : int32)) hoist11 in + letb hoist13 := impl_u32__wrapping_add hoist12 x in letm[choice_typeMonad.result_bind_code int32] hoist14 := ControlFlow_Break hoist13 in ControlFlow_Continue (never_to_any hoist14))) : both L1 I1 int32. Fail Next Obligation. -Definition x_loc : Location := - (int32;2%nat). -Equations simplifiable_return {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (c1 : both L1 I1 'bool) (c2 : both L2 I2 'bool) (c3 : both L3 I3 'bool) : both (L1 :|: L2 :|: L3 :|: fset [x_loc]) (I1 :|: I2 :|: I3) int32 := +Equations simplifiable_return {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (c1 : both L1 I1 'bool) (c2 : both L2 I2 'bool) (c3 : both L3 I3 'bool) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32 := simplifiable_return c1 c2 c3 := solve_lift (run (letb x loc(x_loc) := ret_both (0 : int32) in letm[choice_typeMonad.result_bind_code int32] _ := ifb c1 @@ -136,7 +181,7 @@ Equations simplifiable_return {L1 : {fset Location}} {L2 : {fset Location}} {L3 ControlFlow_Continue (letb _ := assign todo(term) in ret_both (tt : 'unit)) else () in - ControlFlow_Continue x)) : both (L1 :|: L2 :|: L3 :|: fset [x_loc]) (I1 :|: I2 :|: I3) int32. + ControlFlow_Continue x)) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. Fail Next Obligation. Equations simplifiable_question_mark {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I2 : Interface} (c : both L1 I1 'bool) (x : both L2 I2 (t_Option int32)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32) := @@ -167,11 +212,11 @@ Equations options {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Loca letb hoist22 := hoist21 >.? (ret_both (10 : int8)) in letm[choice_typeMonad.option_bind_code] hoist28 := ifb hoist22 then letm[choice_typeMonad.option_bind_code] hoist23 := x in - Option_Some (letb hoist24 := impl__u8__wrapping_add hoist23 (ret_both (3 : int8)) in + Option_Some (letb hoist24 := impl_u8__wrapping_add hoist23 (ret_both (3 : int8)) in Option_Some hoist24) else letm[choice_typeMonad.option_bind_code] hoist26 := x in letm[choice_typeMonad.option_bind_code] hoist25 := y in - Option_Some (letb hoist27 := impl__u8__wrapping_add hoist26 hoist25 in + Option_Some (letb hoist27 := impl_u8__wrapping_add hoist26 hoist25 in Option_Some hoist27) in letm[choice_typeMonad.option_bind_code] hoist29 := hoist28 in letm[choice_typeMonad.option_bind_code] v := matchb hoist29 with @@ -188,15 +233,13 @@ Equations options {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Loca Option_Some (solve_lift (ret_both (12 : int8))) end in letm[choice_typeMonad.option_bind_code] hoist30 := x in - letb hoist32 := impl__u8__wrapping_add v hoist30 in + letb hoist32 := impl_u8__wrapping_add v hoist30 in letm[choice_typeMonad.option_bind_code] hoist31 := y in - Option_Some (letb hoist33 := impl__u8__wrapping_add hoist32 hoist31 in + Option_Some (letb hoist33 := impl_u8__wrapping_add hoist32 hoist31 in Option_Some hoist33))) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (t_Option int8). Fail Next Obligation. -Definition y_loc : Location := - (int32;3%nat). -Equations question_mark {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both (L1 :|: fset [y_loc]) I1 (t_Result int32 int32) := +Equations question_mark {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 (t_Result int32 int32) := question_mark x := solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := ifb x >.? (ret_both (40 : int32)) then letb y loc(y_loc) := ret_both (0 : int32) in @@ -208,7 +251,7 @@ Equations question_mark {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 then impl__map_err (Result_Err (ret_both (12 : int8))) f_from else () else () in - Result_Ok (Result_Ok (impl__u32__wrapping_add (ret_both (3 : int32)) x)))) : both (L1 :|: fset [y_loc]) I1 (t_Result int32 int32). + Result_Ok (Result_Ok (impl_u32__wrapping_add (ret_both (3 : int32)) x)))) : both L1 I1 (t_Result int32 int32). Fail Next Obligation. Definition t_A : choice_type := @@ -303,83 +346,6 @@ Fail Next Obligation. (*Not implemented yet? todo(item)*) -(*Not implemented yet? todo(item)*) - -(*Not implemented yet? todo(item)*) -''' -"Side_effects_Issue_1083_.v" = ''' -(* File automatically generated by Hacspec *) -Set Warnings "-notation-overridden,-ambiguous-paths". -From Crypt Require Import choice_type Package Prelude. -Import PackageNotation. -From extructures Require Import ord fset. -From mathcomp Require Import word_ssrZ word. -From Jasmin Require Import word. - -From Coq Require Import ZArith. -From Coq Require Import Strings.String. -Import List.ListNotations. -Open Scope list_scope. -Open Scope Z_scope. -Open Scope bool_scope. - -From Hacspec Require Import ChoiceEquality. -From Hacspec Require Import LocationUtility. -From Hacspec Require Import Hacspec_Lib_Comparable. -From Hacspec Require Import Hacspec_Lib_Pre. -From Hacspec Require Import Hacspec_Lib. - -Open Scope hacspec_scope. -Import choice.Choice.Exports. - -Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. - -Class t_MyFrom (Self : choice_type) := { - f_my_from_loc : {fset Location} ; - f_my_from : (forall {L1 I1}, both L1 I1 v_T -> both (L1 :|: f_my_from_loc) I1 v_Self) ; -}. -Hint Unfold f_my_from_loc. - -#[global] Program Instance int16_t_MyFrom : t_MyFrom int16 int8 := - let f_my_from := fun {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) => solve_lift (cast_int (WS2 := _) x) : both (L1 :|: fset []) I1 int16 in - {| f_my_from_loc := (fset [] : {fset Location}); - f_my_from := (@f_my_from)|}. -Fail Next Obligation. -Hint Unfold int16_t_MyFrom. - -Equations f {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) : both L1 I1 (t_Result int16 int16) := - f x := - solve_lift (run (letm[choice_typeMonad.result_bind_code int16] _ := impl__map_err (Result_Err (ret_both (1 : int8))) f_from in - Result_Ok (Result_Ok (f_my_from x)))) : both L1 I1 (t_Result int16 int16). -Fail Next Obligation. -''' -"Side_effects_Issue_1089_.v" = ''' -(* File automatically generated by Hacspec *) -Set Warnings "-notation-overridden,-ambiguous-paths". -From Crypt Require Import choice_type Package Prelude. -Import PackageNotation. -From extructures Require Import ord fset. -From mathcomp Require Import word_ssrZ word. -From Jasmin Require Import word. - -From Coq Require Import ZArith. -From Coq Require Import Strings.String. -Import List.ListNotations. -Open Scope list_scope. -Open Scope Z_scope. -Open Scope bool_scope. - -From Hacspec Require Import ChoiceEquality. -From Hacspec Require Import LocationUtility. -From Hacspec Require Import Hacspec_Lib_Comparable. -From Hacspec Require Import Hacspec_Lib_Pre. -From Hacspec Require Import Hacspec_Lib. - -Open Scope hacspec_scope. -Import choice.Choice.Exports. - -Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. - Equations test {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I2 : Interface} (x : both L1 I1 (t_Option int32)) (y : both L2 I2 (t_Option int32)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32) := test x y := solve_lift (run (letb hoist40 := fun i => @@ -390,7 +356,7 @@ Equations test {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I hoist41)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32). Fail Next Obligation. ''' -"Side_effects_Nested_return.v" = ''' +"Side_effects_Issue_1083_.v" = ''' (* File automatically generated by Hacspec *) Set Warnings "-notation-overridden,-ambiguous-paths". From Crypt Require Import choice_type Package Prelude. @@ -417,6 +383,8 @@ Import choice.Choice.Exports. Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. +(*Not implemented yet? todo(item)*) + Equations other_fun {L1 : {fset Location}} {I1 : Interface} (rng : both L1 I1 int8) : both L1 I1 (int8 × t_Result 'unit 'unit) := other_fun rng := letb hax_temp_output := Result_Ok (ret_both (tt : 'unit)) in @@ -444,4 +412,934 @@ Equations fun {L1 : {fset Location}} {I1 : Interface} (rng : both L1 I1 int8) : ControlFlow_Continue (letb hax_temp_output := never_to_any hoist48 in prod_b (rng,hax_temp_output)))) : both L1 I1 (int8 × t_Result 'unit 'unit). Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Class t_MyFrom (Self : choice_type) := { + f_my_from_loc : {fset Location} ; + f_my_from : (forall {L1 I1}, both L1 I1 v_T -> both (L1 :|: f_my_from_loc) I1 v_Self) ; +}. +Hint Unfold f_my_from_loc. + +#[global] Program Instance int16_t_MyFrom : t_MyFrom int16 int8 := + let f_my_from := fun {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) => solve_lift (cast_int (WS2 := _) x) : both (L1 :|: fset []) I1 int16 in + {| f_my_from_loc := (fset [] : {fset Location}); + f_my_from := (@f_my_from)|}. +Fail Next Obligation. +Hint Unfold int16_t_MyFrom. + +Equations f {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) : both L1 I1 (t_Result int16 int16) := + f x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int16] _ := impl__map_err (Result_Err (ret_both (1 : int8))) f_from in + Result_Ok (Result_Ok (f_my_from x)))) : both L1 I1 (t_Result int16 int16). +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations add3 {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (x : both L1 I1 int32) (y : both L2 I2 int32) (z : both L3 I3 int32) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32 := + add3 x y z := + solve_lift (impl_u32__wrapping_add (impl_u32__wrapping_add x y) z) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. +Fail Next Obligation. + +Equations local_mutation {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 int32 := + local_mutation x := + letb y loc(y_loc) := ret_both (0 : int32) in + letb _ := assign todo(term) in + letb hoist1 := x >.? (ret_both (3 : int32)) in + solve_lift (ifb hoist1 + then letb _ := assign todo(term) in + letb y loc(y_loc) := x ./ (ret_both (2 : int32)) in + letb _ := assign todo(term) in + letb hoist2 := ret_both (0 : int32) in + letb hoist3 := Build_t_Range (f_start := hoist2) (f_end := ret_both (10 : int32)) in + letb hoist4 := f_into_iter hoist3 in + letb _ := foldi_both_list hoist4 (fun i => + ssp (fun _ => + assign todo(term) : (both (*0*)(L1:|:fset []) (I1) 'unit))) (ret_both (tt : 'unit)) in + impl_u32__wrapping_add x y + else letb hoist7 := matchb x with + | 12 => + letb _ := assign todo(term) in + solve_lift (ret_both (3 : int32)) + | 13 => + letb hoist6 := x in + letb _ := assign todo(term) in + letb hoist5 := impl_u32__wrapping_add (ret_both (123 : int32)) x in + solve_lift (add3 hoist6 hoist5 x) + | _ => + solve_lift (ret_both (0 : int32)) + end in + letb _ := assign todo(term) in + impl_u32__wrapping_add x y) : both L1 I1 int32. +Fail Next Obligation. + +Equations early_returns {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 int32 := + early_returns x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := ifb x >.? (ret_both (3 : int32)) + then letm[choice_typeMonad.result_bind_code int32] hoist8 := ControlFlow_Break (ret_both (0 : int32)) in + ControlFlow_Continue (never_to_any hoist8) + else () in + letb hoist9 := x >.? (ret_both (30 : int32)) in + letm[choice_typeMonad.result_bind_code int32] hoist11 := ifb hoist9 + then matchb ret_both (true : 'bool) with + | true => + letm[choice_typeMonad.result_bind_code int32] hoist10 := ControlFlow_Break (ret_both (34 : int32)) in + ControlFlow_Continue (solve_lift (never_to_any hoist10)) + | _ => + ControlFlow_Continue (solve_lift (ret_both (3 : int32))) + end + else ControlFlow_Continue (letb _ := assign todo(term) in + x .+ (ret_both (1 : int32))) in + letb hoist12 := impl_u32__wrapping_add (ret_both (123 : int32)) hoist11 in + letb hoist13 := impl_u32__wrapping_add hoist12 x in + letm[choice_typeMonad.result_bind_code int32] hoist14 := ControlFlow_Break hoist13 in + ControlFlow_Continue (never_to_any hoist14))) : both L1 I1 int32. +Fail Next Obligation. + +Equations simplifiable_return {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (c1 : both L1 I1 'bool) (c2 : both L2 I2 'bool) (c3 : both L3 I3 'bool) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32 := + simplifiable_return c1 c2 c3 := + solve_lift (run (letb x loc(x_loc) := ret_both (0 : int32) in + letm[choice_typeMonad.result_bind_code int32] _ := ifb c1 + then letm[choice_typeMonad.result_bind_code int32] _ := ifb c2 + then letb _ := assign todo(term) in + ifb c3 + then letm[choice_typeMonad.result_bind_code int32] hoist15 := ControlFlow_Break (ret_both (1 : int32)) in + ControlFlow_Continue (never_to_any hoist15) + else () + else () in + ControlFlow_Continue (letb _ := assign todo(term) in + ret_both (tt : 'unit)) + else () in + ControlFlow_Continue x)) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. +Fail Next Obligation. + +Equations simplifiable_question_mark {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I2 : Interface} (c : both L1 I1 'bool) (x : both L2 I2 (t_Option int32)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32) := + simplifiable_question_mark c x := + solve_lift (run (letm[choice_typeMonad.option_bind_code] a := ifb c + then letm[choice_typeMonad.option_bind_code] hoist16 := x in + Option_Some (hoist16 .+ (ret_both (10 : int32))) + else Option_Some (ret_both (0 : int32)) in + Option_Some (letb b := ret_both (20 : int32) in + Option_Some (a .+ b)))) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32). +Fail Next Obligation. + +Equations direct_result_question_mark {L1 : {fset Location}} {I1 : Interface} (y : both L1 I1 (t_Result 'unit int32)) : both L1 I1 (t_Result int8 int32) := + direct_result_question_mark y := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := y in + Result_Ok (Result_Ok (ret_both (0 : int8))))) : both L1 I1 (t_Result int8 int32). +Fail Next Obligation. + +Equations direct_result_question_mark_coercion {L1 : {fset Location}} {I1 : Interface} (y : both L1 I1 (t_Result int8 int16)) : both L1 I1 (t_Result int8 int32) := + direct_result_question_mark_coercion y := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] hoist17 := impl__map_err y f_from in + Result_Ok (Result_Ok hoist17))) : both L1 I1 (t_Result int8 int32). +Fail Next Obligation. + +Equations options {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (x : both L1 I1 (t_Option int8)) (y : both L2 I2 (t_Option int8)) (z : both L3 I3 (t_Option int64)) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (t_Option int8) := + options x y z := + solve_lift (run (letm[choice_typeMonad.option_bind_code] hoist21 := x in + letb hoist22 := hoist21 >.? (ret_both (10 : int8)) in + letm[choice_typeMonad.option_bind_code] hoist28 := ifb hoist22 + then letm[choice_typeMonad.option_bind_code] hoist23 := x in + Option_Some (letb hoist24 := impl_u8__wrapping_add hoist23 (ret_both (3 : int8)) in + Option_Some hoist24) + else letm[choice_typeMonad.option_bind_code] hoist26 := x in + letm[choice_typeMonad.option_bind_code] hoist25 := y in + Option_Some (letb hoist27 := impl_u8__wrapping_add hoist26 hoist25 in + Option_Some hoist27) in + letm[choice_typeMonad.option_bind_code] hoist29 := hoist28 in + letm[choice_typeMonad.option_bind_code] v := matchb hoist29 with + | 3 => + Option_None + | 4 => + letm[choice_typeMonad.option_bind_code] hoist18 := z in + Option_Some (letb hoist19 := hoist18 >.? (ret_both (4 : int64)) in + letb hoist20 := ifb hoist19 + then ret_both (0 : int8) + else ret_both (3 : int8) in + solve_lift ((ret_both (4 : int8)) .+ hoist20)) + | _ => + Option_Some (solve_lift (ret_both (12 : int8))) + end in + letm[choice_typeMonad.option_bind_code] hoist30 := x in + letb hoist32 := impl_u8__wrapping_add v hoist30 in + letm[choice_typeMonad.option_bind_code] hoist31 := y in + Option_Some (letb hoist33 := impl_u8__wrapping_add hoist32 hoist31 in + Option_Some hoist33))) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (t_Option int8). +Fail Next Obligation. + +Equations question_mark {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 (t_Result int32 int32) := + question_mark x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := ifb x >.? (ret_both (40 : int32)) + then letb y loc(y_loc) := ret_both (0 : int32) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb hoist34 := x >.? (ret_both (90 : int32)) in + ifb hoist34 + then impl__map_err (Result_Err (ret_both (12 : int8))) f_from + else () + else () in + Result_Ok (Result_Ok (impl_u32__wrapping_add (ret_both (3 : int32)) x)))) : both L1 I1 (t_Result int32 int32). +Fail Next Obligation. + +Definition t_A : choice_type := + 'unit. +Equations Build_t_A : both (fset []) (fset []) (t_A) := + Build_t_A := + solve_lift (ret_both (tt (* Empty tuple *) : (t_A))) : both (fset []) (fset []) (t_A). +Fail Next Obligation. + +Definition t_B : choice_type := + 'unit. +Equations Build_t_B : both (fset []) (fset []) (t_B) := + Build_t_B := + solve_lift (ret_both (tt (* Empty tuple *) : (t_B))) : both (fset []) (fset []) (t_B). +Fail Next Obligation. + +Equations monad_lifting {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) : both L1 I1 (t_Result t_A t_B) := + monad_lifting x := + solve_lift (run (ifb x >.? (ret_both (123 : int8)) + then letm[choice_typeMonad.result_bind_code (t_Result t_A t_B)] hoist35 := ControlFlow_Continue (Result_Err B) in + letb hoist36 := Result_Ok hoist35 in + letm[choice_typeMonad.result_bind_code (t_Result t_A t_B)] hoist37 := ControlFlow_Break hoist36 in + ControlFlow_Continue (never_to_any hoist37) + else ControlFlow_Continue (Result_Ok A))) : both L1 I1 (t_Result t_A t_B). +Fail Next Obligation. + +Definition t_Bar : choice_type := + ('bool × nseq ('bool × 'bool) 6 × 'bool). +Equations f_a {L : {fset Location}} {I : Interface} (s : both L I t_Bar) : both L I 'bool := + f_a s := + bind_both s (fun x => + solve_lift (ret_both (fst x : 'bool))) : both L I 'bool. +Fail Next Obligation. +Equations f_b {L : {fset Location}} {I : Interface} (s : both L I t_Bar) : both L I (nseq ('bool × 'bool) 6 × 'bool) := + f_b s := + bind_both s (fun x => + solve_lift (ret_both (snd x : (nseq ('bool × 'bool) 6 × 'bool)))) : both L I (nseq ('bool × 'bool) 6 × 'bool). +Fail Next Obligation. +Equations Build_t_Bar {L0 : {fset Location}} {L1 : {fset Location}} {I0 : Interface} {I1 : Interface} {f_a : both L0 I0 'bool} {f_b : both L1 I1 (nseq ('bool × 'bool) 6 × 'bool)} : both (L0:|:L1) (I0:|:I1) (t_Bar) := + Build_t_Bar := + bind_both f_b (fun f_b => + bind_both f_a (fun f_a => + solve_lift (ret_both ((f_a,f_b) : (t_Bar))))) : both (L0:|:L1) (I0:|:I1) (t_Bar). +Fail Next Obligation. +Notation "'Build_t_Bar' '[' x ']' '(' 'f_a' ':=' y ')'" := (Build_t_Bar (f_a := y) (f_b := f_b x)). +Notation "'Build_t_Bar' '[' x ']' '(' 'f_b' ':=' y ')'" := (Build_t_Bar (f_a := f_a x) (f_b := y)). + +Definition t_Foo : choice_type := + ('bool × 'bool × t_Vec t_Bar t_Global × nseq t_Bar 6 × t_Bar). +Equations f_x {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I 'bool := + f_x s := + bind_both s (fun x => + solve_lift (ret_both (fst (fst (fst x)) : 'bool))) : both L I 'bool. +Fail Next Obligation. +Equations f_y {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I ('bool × t_Vec t_Bar t_Global) := + f_y s := + bind_both s (fun x => + solve_lift (ret_both (snd (fst (fst x)) : ('bool × t_Vec t_Bar t_Global)))) : both L I ('bool × t_Vec t_Bar t_Global). +Fail Next Obligation. +Equations f_z {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I (nseq t_Bar 6) := + f_z s := + bind_both s (fun x => + solve_lift (ret_both (snd (fst x) : (nseq t_Bar 6)))) : both L I (nseq t_Bar 6). +Fail Next Obligation. +Equations f_bar {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I t_Bar := + f_bar s := + bind_both s (fun x => + solve_lift (ret_both (snd x : t_Bar))) : both L I t_Bar. +Fail Next Obligation. +Equations Build_t_Foo {L0 : {fset Location}} {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I0 : Interface} {I1 : Interface} {I2 : Interface} {I3 : Interface} {f_x : both L0 I0 'bool} {f_y : both L1 I1 ('bool × t_Vec t_Bar t_Global)} {f_z : both L2 I2 (nseq t_Bar 6)} {f_bar : both L3 I3 t_Bar} : both (L0:|:L1:|:L2:|:L3) (I0:|:I1:|:I2:|:I3) (t_Foo) := + Build_t_Foo := + bind_both f_bar (fun f_bar => + bind_both f_z (fun f_z => + bind_both f_y (fun f_y => + bind_both f_x (fun f_x => + solve_lift (ret_both ((f_x,f_y,f_z,f_bar) : (t_Foo))))))) : both (L0:|:L1:|:L2:|:L3) (I0:|:I1:|:I2:|:I3) (t_Foo). +Fail Next Obligation. +Notation "'Build_t_Foo' '[' x ']' '(' 'f_x' ':=' y ')'" := (Build_t_Foo (f_x := y) (f_y := f_y x) (f_z := f_z x) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_y' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := y) (f_z := f_z x) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_z' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := f_y x) (f_z := y) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_bar' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := f_y x) (f_z := f_z x) (f_bar := y)). + +Equations assign_non_trivial_lhs {L1 : {fset Location}} {I1 : Interface} (foo : both L1 I1 t_Foo) : both L1 I1 t_Foo := + assign_non_trivial_lhs foo := + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + solve_lift foo : both L1 I1 t_Foo. +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations test {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I2 : Interface} (x : both L1 I1 (t_Option int32)) (y : both L2 I2 (t_Option int32)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32) := + test x y := + solve_lift (run (letb hoist40 := fun i => + letm[choice_typeMonad.option_bind_code] hoist38 := y in + Option_Some (letb hoist39 := i .+ hoist38 in + Option_Some hoist39) in + letb hoist41 := impl__map x hoist40 in + hoist41)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32). +Fail Next Obligation. +''' +"Side_effects_Issue_1089_.v" = ''' +(* File automatically generated by Hacspec *) +Set Warnings "-notation-overridden,-ambiguous-paths". +From Crypt Require Import choice_type Package Prelude. +Import PackageNotation. +From extructures Require Import ord fset. +From mathcomp Require Import word_ssrZ word. +From Jasmin Require Import word. + +From Coq Require Import ZArith. +From Coq Require Import Strings.String. +Import List.ListNotations. +Open Scope list_scope. +Open Scope Z_scope. +Open Scope bool_scope. + +From Hacspec Require Import ChoiceEquality. +From Hacspec Require Import LocationUtility. +From Hacspec Require Import Hacspec_Lib_Comparable. +From Hacspec Require Import Hacspec_Lib_Pre. +From Hacspec Require Import Hacspec_Lib. + +Open Scope hacspec_scope. +Import choice.Choice.Exports. + +Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. + +(*Not implemented yet? todo(item)*) + +Equations other_fun {L1 : {fset Location}} {I1 : Interface} (rng : both L1 I1 int8) : both L1 I1 (int8 × t_Result 'unit 'unit) := + other_fun rng := + letb hax_temp_output := Result_Ok (ret_both (tt : 'unit)) in + solve_lift (prod_b (rng,hax_temp_output)) : both L1 I1 (int8 × t_Result 'unit 'unit). +Fail Next Obligation. + +Equations fun {L1 : {fset Location}} {I1 : Interface} (rng : both L1 I1 int8) : both L1 I1 (int8 × t_Result 'unit 'unit) := + fun rng := + solve_lift (run (letb '(tmp0,out) := other_fun rng in + letb _ := assign todo(term) in + letb hoist43 := out in + letb hoist44 := f_branch hoist43 in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist45 := matchb hoist44 with + | ControlFlow_Break_case residual => + letb residual := ret_both ((residual) : (t_Result t_Infallible 'unit)) in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist42 := ControlFlow_Break (prod_b (rng,f_from_residual residual)) in + ControlFlow_Continue (solve_lift (never_to_any hoist42)) + | ControlFlow_Continue_case val => + letb val := ret_both ((val) : ('unit)) in + ControlFlow_Continue (solve_lift val) + end in + letb hoist46 := Result_Ok hoist45 in + letb hoist47 := prod_b (rng,hoist46) in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist48 := ControlFlow_Break hoist47 in + ControlFlow_Continue (letb hax_temp_output := never_to_any hoist48 in + prod_b (rng,hax_temp_output)))) : both L1 I1 (int8 × t_Result 'unit 'unit). +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Class t_MyFrom (Self : choice_type) := { + f_my_from_loc : {fset Location} ; + f_my_from : (forall {L1 I1}, both L1 I1 v_T -> both (L1 :|: f_my_from_loc) I1 v_Self) ; +}. +Hint Unfold f_my_from_loc. + +#[global] Program Instance int16_t_MyFrom : t_MyFrom int16 int8 := + let f_my_from := fun {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) => solve_lift (cast_int (WS2 := _) x) : both (L1 :|: fset []) I1 int16 in + {| f_my_from_loc := (fset [] : {fset Location}); + f_my_from := (@f_my_from)|}. +Fail Next Obligation. +Hint Unfold int16_t_MyFrom. + +Equations f {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) : both L1 I1 (t_Result int16 int16) := + f x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int16] _ := impl__map_err (Result_Err (ret_both (1 : int8))) f_from in + Result_Ok (Result_Ok (f_my_from x)))) : both L1 I1 (t_Result int16 int16). +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations add3 {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (x : both L1 I1 int32) (y : both L2 I2 int32) (z : both L3 I3 int32) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32 := + add3 x y z := + solve_lift (impl_u32__wrapping_add (impl_u32__wrapping_add x y) z) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. +Fail Next Obligation. + +Equations local_mutation {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 int32 := + local_mutation x := + letb y loc(y_loc) := ret_both (0 : int32) in + letb _ := assign todo(term) in + letb hoist1 := x >.? (ret_both (3 : int32)) in + solve_lift (ifb hoist1 + then letb _ := assign todo(term) in + letb y loc(y_loc) := x ./ (ret_both (2 : int32)) in + letb _ := assign todo(term) in + letb hoist2 := ret_both (0 : int32) in + letb hoist3 := Build_t_Range (f_start := hoist2) (f_end := ret_both (10 : int32)) in + letb hoist4 := f_into_iter hoist3 in + letb _ := foldi_both_list hoist4 (fun i => + ssp (fun _ => + assign todo(term) : (both (*0*)(L1:|:fset []) (I1) 'unit))) (ret_both (tt : 'unit)) in + impl_u32__wrapping_add x y + else letb hoist7 := matchb x with + | 12 => + letb _ := assign todo(term) in + solve_lift (ret_both (3 : int32)) + | 13 => + letb hoist6 := x in + letb _ := assign todo(term) in + letb hoist5 := impl_u32__wrapping_add (ret_both (123 : int32)) x in + solve_lift (add3 hoist6 hoist5 x) + | _ => + solve_lift (ret_both (0 : int32)) + end in + letb _ := assign todo(term) in + impl_u32__wrapping_add x y) : both L1 I1 int32. +Fail Next Obligation. + +Equations early_returns {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 int32 := + early_returns x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := ifb x >.? (ret_both (3 : int32)) + then letm[choice_typeMonad.result_bind_code int32] hoist8 := ControlFlow_Break (ret_both (0 : int32)) in + ControlFlow_Continue (never_to_any hoist8) + else () in + letb hoist9 := x >.? (ret_both (30 : int32)) in + letm[choice_typeMonad.result_bind_code int32] hoist11 := ifb hoist9 + then matchb ret_both (true : 'bool) with + | true => + letm[choice_typeMonad.result_bind_code int32] hoist10 := ControlFlow_Break (ret_both (34 : int32)) in + ControlFlow_Continue (solve_lift (never_to_any hoist10)) + | _ => + ControlFlow_Continue (solve_lift (ret_both (3 : int32))) + end + else ControlFlow_Continue (letb _ := assign todo(term) in + x .+ (ret_both (1 : int32))) in + letb hoist12 := impl_u32__wrapping_add (ret_both (123 : int32)) hoist11 in + letb hoist13 := impl_u32__wrapping_add hoist12 x in + letm[choice_typeMonad.result_bind_code int32] hoist14 := ControlFlow_Break hoist13 in + ControlFlow_Continue (never_to_any hoist14))) : both L1 I1 int32. +Fail Next Obligation. + +Equations simplifiable_return {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (c1 : both L1 I1 'bool) (c2 : both L2 I2 'bool) (c3 : both L3 I3 'bool) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32 := + simplifiable_return c1 c2 c3 := + solve_lift (run (letb x loc(x_loc) := ret_both (0 : int32) in + letm[choice_typeMonad.result_bind_code int32] _ := ifb c1 + then letm[choice_typeMonad.result_bind_code int32] _ := ifb c2 + then letb _ := assign todo(term) in + ifb c3 + then letm[choice_typeMonad.result_bind_code int32] hoist15 := ControlFlow_Break (ret_both (1 : int32)) in + ControlFlow_Continue (never_to_any hoist15) + else () + else () in + ControlFlow_Continue (letb _ := assign todo(term) in + ret_both (tt : 'unit)) + else () in + ControlFlow_Continue x)) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. +Fail Next Obligation. + +Equations simplifiable_question_mark {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I2 : Interface} (c : both L1 I1 'bool) (x : both L2 I2 (t_Option int32)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32) := + simplifiable_question_mark c x := + solve_lift (run (letm[choice_typeMonad.option_bind_code] a := ifb c + then letm[choice_typeMonad.option_bind_code] hoist16 := x in + Option_Some (hoist16 .+ (ret_both (10 : int32))) + else Option_Some (ret_both (0 : int32)) in + Option_Some (letb b := ret_both (20 : int32) in + Option_Some (a .+ b)))) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32). +Fail Next Obligation. + +Equations direct_result_question_mark {L1 : {fset Location}} {I1 : Interface} (y : both L1 I1 (t_Result 'unit int32)) : both L1 I1 (t_Result int8 int32) := + direct_result_question_mark y := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := y in + Result_Ok (Result_Ok (ret_both (0 : int8))))) : both L1 I1 (t_Result int8 int32). +Fail Next Obligation. + +Equations direct_result_question_mark_coercion {L1 : {fset Location}} {I1 : Interface} (y : both L1 I1 (t_Result int8 int16)) : both L1 I1 (t_Result int8 int32) := + direct_result_question_mark_coercion y := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] hoist17 := impl__map_err y f_from in + Result_Ok (Result_Ok hoist17))) : both L1 I1 (t_Result int8 int32). +Fail Next Obligation. + +Equations options {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (x : both L1 I1 (t_Option int8)) (y : both L2 I2 (t_Option int8)) (z : both L3 I3 (t_Option int64)) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (t_Option int8) := + options x y z := + solve_lift (run (letm[choice_typeMonad.option_bind_code] hoist21 := x in + letb hoist22 := hoist21 >.? (ret_both (10 : int8)) in + letm[choice_typeMonad.option_bind_code] hoist28 := ifb hoist22 + then letm[choice_typeMonad.option_bind_code] hoist23 := x in + Option_Some (letb hoist24 := impl_u8__wrapping_add hoist23 (ret_both (3 : int8)) in + Option_Some hoist24) + else letm[choice_typeMonad.option_bind_code] hoist26 := x in + letm[choice_typeMonad.option_bind_code] hoist25 := y in + Option_Some (letb hoist27 := impl_u8__wrapping_add hoist26 hoist25 in + Option_Some hoist27) in + letm[choice_typeMonad.option_bind_code] hoist29 := hoist28 in + letm[choice_typeMonad.option_bind_code] v := matchb hoist29 with + | 3 => + Option_None + | 4 => + letm[choice_typeMonad.option_bind_code] hoist18 := z in + Option_Some (letb hoist19 := hoist18 >.? (ret_both (4 : int64)) in + letb hoist20 := ifb hoist19 + then ret_both (0 : int8) + else ret_both (3 : int8) in + solve_lift ((ret_both (4 : int8)) .+ hoist20)) + | _ => + Option_Some (solve_lift (ret_both (12 : int8))) + end in + letm[choice_typeMonad.option_bind_code] hoist30 := x in + letb hoist32 := impl_u8__wrapping_add v hoist30 in + letm[choice_typeMonad.option_bind_code] hoist31 := y in + Option_Some (letb hoist33 := impl_u8__wrapping_add hoist32 hoist31 in + Option_Some hoist33))) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (t_Option int8). +Fail Next Obligation. + +Equations question_mark {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 (t_Result int32 int32) := + question_mark x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := ifb x >.? (ret_both (40 : int32)) + then letb y loc(y_loc) := ret_both (0 : int32) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb hoist34 := x >.? (ret_both (90 : int32)) in + ifb hoist34 + then impl__map_err (Result_Err (ret_both (12 : int8))) f_from + else () + else () in + Result_Ok (Result_Ok (impl_u32__wrapping_add (ret_both (3 : int32)) x)))) : both L1 I1 (t_Result int32 int32). +Fail Next Obligation. + +Definition t_A : choice_type := + 'unit. +Equations Build_t_A : both (fset []) (fset []) (t_A) := + Build_t_A := + solve_lift (ret_both (tt (* Empty tuple *) : (t_A))) : both (fset []) (fset []) (t_A). +Fail Next Obligation. + +Definition t_B : choice_type := + 'unit. +Equations Build_t_B : both (fset []) (fset []) (t_B) := + Build_t_B := + solve_lift (ret_both (tt (* Empty tuple *) : (t_B))) : both (fset []) (fset []) (t_B). +Fail Next Obligation. + +Equations monad_lifting {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) : both L1 I1 (t_Result t_A t_B) := + monad_lifting x := + solve_lift (run (ifb x >.? (ret_both (123 : int8)) + then letm[choice_typeMonad.result_bind_code (t_Result t_A t_B)] hoist35 := ControlFlow_Continue (Result_Err B) in + letb hoist36 := Result_Ok hoist35 in + letm[choice_typeMonad.result_bind_code (t_Result t_A t_B)] hoist37 := ControlFlow_Break hoist36 in + ControlFlow_Continue (never_to_any hoist37) + else ControlFlow_Continue (Result_Ok A))) : both L1 I1 (t_Result t_A t_B). +Fail Next Obligation. + +Definition t_Bar : choice_type := + ('bool × nseq ('bool × 'bool) 6 × 'bool). +Equations f_a {L : {fset Location}} {I : Interface} (s : both L I t_Bar) : both L I 'bool := + f_a s := + bind_both s (fun x => + solve_lift (ret_both (fst x : 'bool))) : both L I 'bool. +Fail Next Obligation. +Equations f_b {L : {fset Location}} {I : Interface} (s : both L I t_Bar) : both L I (nseq ('bool × 'bool) 6 × 'bool) := + f_b s := + bind_both s (fun x => + solve_lift (ret_both (snd x : (nseq ('bool × 'bool) 6 × 'bool)))) : both L I (nseq ('bool × 'bool) 6 × 'bool). +Fail Next Obligation. +Equations Build_t_Bar {L0 : {fset Location}} {L1 : {fset Location}} {I0 : Interface} {I1 : Interface} {f_a : both L0 I0 'bool} {f_b : both L1 I1 (nseq ('bool × 'bool) 6 × 'bool)} : both (L0:|:L1) (I0:|:I1) (t_Bar) := + Build_t_Bar := + bind_both f_b (fun f_b => + bind_both f_a (fun f_a => + solve_lift (ret_both ((f_a,f_b) : (t_Bar))))) : both (L0:|:L1) (I0:|:I1) (t_Bar). +Fail Next Obligation. +Notation "'Build_t_Bar' '[' x ']' '(' 'f_a' ':=' y ')'" := (Build_t_Bar (f_a := y) (f_b := f_b x)). +Notation "'Build_t_Bar' '[' x ']' '(' 'f_b' ':=' y ')'" := (Build_t_Bar (f_a := f_a x) (f_b := y)). + +Definition t_Foo : choice_type := + ('bool × 'bool × t_Vec t_Bar t_Global × nseq t_Bar 6 × t_Bar). +Equations f_x {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I 'bool := + f_x s := + bind_both s (fun x => + solve_lift (ret_both (fst (fst (fst x)) : 'bool))) : both L I 'bool. +Fail Next Obligation. +Equations f_y {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I ('bool × t_Vec t_Bar t_Global) := + f_y s := + bind_both s (fun x => + solve_lift (ret_both (snd (fst (fst x)) : ('bool × t_Vec t_Bar t_Global)))) : both L I ('bool × t_Vec t_Bar t_Global). +Fail Next Obligation. +Equations f_z {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I (nseq t_Bar 6) := + f_z s := + bind_both s (fun x => + solve_lift (ret_both (snd (fst x) : (nseq t_Bar 6)))) : both L I (nseq t_Bar 6). +Fail Next Obligation. +Equations f_bar {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I t_Bar := + f_bar s := + bind_both s (fun x => + solve_lift (ret_both (snd x : t_Bar))) : both L I t_Bar. +Fail Next Obligation. +Equations Build_t_Foo {L0 : {fset Location}} {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I0 : Interface} {I1 : Interface} {I2 : Interface} {I3 : Interface} {f_x : both L0 I0 'bool} {f_y : both L1 I1 ('bool × t_Vec t_Bar t_Global)} {f_z : both L2 I2 (nseq t_Bar 6)} {f_bar : both L3 I3 t_Bar} : both (L0:|:L1:|:L2:|:L3) (I0:|:I1:|:I2:|:I3) (t_Foo) := + Build_t_Foo := + bind_both f_bar (fun f_bar => + bind_both f_z (fun f_z => + bind_both f_y (fun f_y => + bind_both f_x (fun f_x => + solve_lift (ret_both ((f_x,f_y,f_z,f_bar) : (t_Foo))))))) : both (L0:|:L1:|:L2:|:L3) (I0:|:I1:|:I2:|:I3) (t_Foo). +Fail Next Obligation. +Notation "'Build_t_Foo' '[' x ']' '(' 'f_x' ':=' y ')'" := (Build_t_Foo (f_x := y) (f_y := f_y x) (f_z := f_z x) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_y' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := y) (f_z := f_z x) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_z' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := f_y x) (f_z := y) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_bar' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := f_y x) (f_z := f_z x) (f_bar := y)). + +Equations assign_non_trivial_lhs {L1 : {fset Location}} {I1 : Interface} (foo : both L1 I1 t_Foo) : both L1 I1 t_Foo := + assign_non_trivial_lhs foo := + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + solve_lift foo : both L1 I1 t_Foo. +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations test {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I2 : Interface} (x : both L1 I1 (t_Option int32)) (y : both L2 I2 (t_Option int32)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32) := + test x y := + solve_lift (run (letb hoist40 := fun i => + letm[choice_typeMonad.option_bind_code] hoist38 := y in + Option_Some (letb hoist39 := i .+ hoist38 in + Option_Some hoist39) in + letb hoist41 := impl__map x hoist40 in + hoist41)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32). +Fail Next Obligation. +''' +"Side_effects_Nested_return.v" = ''' +(* File automatically generated by Hacspec *) +Set Warnings "-notation-overridden,-ambiguous-paths". +From Crypt Require Import choice_type Package Prelude. +Import PackageNotation. +From extructures Require Import ord fset. +From mathcomp Require Import word_ssrZ word. +From Jasmin Require Import word. + +From Coq Require Import ZArith. +From Coq Require Import Strings.String. +Import List.ListNotations. +Open Scope list_scope. +Open Scope Z_scope. +Open Scope bool_scope. + +From Hacspec Require Import ChoiceEquality. +From Hacspec Require Import LocationUtility. +From Hacspec Require Import Hacspec_Lib_Comparable. +From Hacspec Require Import Hacspec_Lib_Pre. +From Hacspec Require Import Hacspec_Lib. + +Open Scope hacspec_scope. +Import choice.Choice.Exports. + +Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. + +(*Not implemented yet? todo(item)*) + +Equations other_fun {L1 : {fset Location}} {I1 : Interface} (rng : both L1 I1 int8) : both L1 I1 (int8 × t_Result 'unit 'unit) := + other_fun rng := + letb hax_temp_output := Result_Ok (ret_both (tt : 'unit)) in + solve_lift (prod_b (rng,hax_temp_output)) : both L1 I1 (int8 × t_Result 'unit 'unit). +Fail Next Obligation. + +Equations fun {L1 : {fset Location}} {I1 : Interface} (rng : both L1 I1 int8) : both L1 I1 (int8 × t_Result 'unit 'unit) := + fun rng := + solve_lift (run (letb '(tmp0,out) := other_fun rng in + letb _ := assign todo(term) in + letb hoist43 := out in + letb hoist44 := f_branch hoist43 in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist45 := matchb hoist44 with + | ControlFlow_Break_case residual => + letb residual := ret_both ((residual) : (t_Result t_Infallible 'unit)) in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist42 := ControlFlow_Break (prod_b (rng,f_from_residual residual)) in + ControlFlow_Continue (solve_lift (never_to_any hoist42)) + | ControlFlow_Continue_case val => + letb val := ret_both ((val) : ('unit)) in + ControlFlow_Continue (solve_lift val) + end in + letb hoist46 := Result_Ok hoist45 in + letb hoist47 := prod_b (rng,hoist46) in + letm[choice_typeMonad.result_bind_code (int8 × t_Result 'unit 'unit)] hoist48 := ControlFlow_Break hoist47 in + ControlFlow_Continue (letb hax_temp_output := never_to_any hoist48 in + prod_b (rng,hax_temp_output)))) : both L1 I1 (int8 × t_Result 'unit 'unit). +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Class t_MyFrom (Self : choice_type) := { + f_my_from_loc : {fset Location} ; + f_my_from : (forall {L1 I1}, both L1 I1 v_T -> both (L1 :|: f_my_from_loc) I1 v_Self) ; +}. +Hint Unfold f_my_from_loc. + +#[global] Program Instance int16_t_MyFrom : t_MyFrom int16 int8 := + let f_my_from := fun {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) => solve_lift (cast_int (WS2 := _) x) : both (L1 :|: fset []) I1 int16 in + {| f_my_from_loc := (fset [] : {fset Location}); + f_my_from := (@f_my_from)|}. +Fail Next Obligation. +Hint Unfold int16_t_MyFrom. + +Equations f {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) : both L1 I1 (t_Result int16 int16) := + f x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int16] _ := impl__map_err (Result_Err (ret_both (1 : int8))) f_from in + Result_Ok (Result_Ok (f_my_from x)))) : both L1 I1 (t_Result int16 int16). +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations add3 {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (x : both L1 I1 int32) (y : both L2 I2 int32) (z : both L3 I3 int32) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32 := + add3 x y z := + solve_lift (impl_u32__wrapping_add (impl_u32__wrapping_add x y) z) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. +Fail Next Obligation. + +Equations local_mutation {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 int32 := + local_mutation x := + letb y loc(y_loc) := ret_both (0 : int32) in + letb _ := assign todo(term) in + letb hoist1 := x >.? (ret_both (3 : int32)) in + solve_lift (ifb hoist1 + then letb _ := assign todo(term) in + letb y loc(y_loc) := x ./ (ret_both (2 : int32)) in + letb _ := assign todo(term) in + letb hoist2 := ret_both (0 : int32) in + letb hoist3 := Build_t_Range (f_start := hoist2) (f_end := ret_both (10 : int32)) in + letb hoist4 := f_into_iter hoist3 in + letb _ := foldi_both_list hoist4 (fun i => + ssp (fun _ => + assign todo(term) : (both (*0*)(L1:|:fset []) (I1) 'unit))) (ret_both (tt : 'unit)) in + impl_u32__wrapping_add x y + else letb hoist7 := matchb x with + | 12 => + letb _ := assign todo(term) in + solve_lift (ret_both (3 : int32)) + | 13 => + letb hoist6 := x in + letb _ := assign todo(term) in + letb hoist5 := impl_u32__wrapping_add (ret_both (123 : int32)) x in + solve_lift (add3 hoist6 hoist5 x) + | _ => + solve_lift (ret_both (0 : int32)) + end in + letb _ := assign todo(term) in + impl_u32__wrapping_add x y) : both L1 I1 int32. +Fail Next Obligation. + +Equations early_returns {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 int32 := + early_returns x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := ifb x >.? (ret_both (3 : int32)) + then letm[choice_typeMonad.result_bind_code int32] hoist8 := ControlFlow_Break (ret_both (0 : int32)) in + ControlFlow_Continue (never_to_any hoist8) + else () in + letb hoist9 := x >.? (ret_both (30 : int32)) in + letm[choice_typeMonad.result_bind_code int32] hoist11 := ifb hoist9 + then matchb ret_both (true : 'bool) with + | true => + letm[choice_typeMonad.result_bind_code int32] hoist10 := ControlFlow_Break (ret_both (34 : int32)) in + ControlFlow_Continue (solve_lift (never_to_any hoist10)) + | _ => + ControlFlow_Continue (solve_lift (ret_both (3 : int32))) + end + else ControlFlow_Continue (letb _ := assign todo(term) in + x .+ (ret_both (1 : int32))) in + letb hoist12 := impl_u32__wrapping_add (ret_both (123 : int32)) hoist11 in + letb hoist13 := impl_u32__wrapping_add hoist12 x in + letm[choice_typeMonad.result_bind_code int32] hoist14 := ControlFlow_Break hoist13 in + ControlFlow_Continue (never_to_any hoist14))) : both L1 I1 int32. +Fail Next Obligation. + +Equations simplifiable_return {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (c1 : both L1 I1 'bool) (c2 : both L2 I2 'bool) (c3 : both L3 I3 'bool) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32 := + simplifiable_return c1 c2 c3 := + solve_lift (run (letb x loc(x_loc) := ret_both (0 : int32) in + letm[choice_typeMonad.result_bind_code int32] _ := ifb c1 + then letm[choice_typeMonad.result_bind_code int32] _ := ifb c2 + then letb _ := assign todo(term) in + ifb c3 + then letm[choice_typeMonad.result_bind_code int32] hoist15 := ControlFlow_Break (ret_both (1 : int32)) in + ControlFlow_Continue (never_to_any hoist15) + else () + else () in + ControlFlow_Continue (letb _ := assign todo(term) in + ret_both (tt : 'unit)) + else () in + ControlFlow_Continue x)) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) int32. +Fail Next Obligation. + +Equations simplifiable_question_mark {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I2 : Interface} (c : both L1 I1 'bool) (x : both L2 I2 (t_Option int32)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32) := + simplifiable_question_mark c x := + solve_lift (run (letm[choice_typeMonad.option_bind_code] a := ifb c + then letm[choice_typeMonad.option_bind_code] hoist16 := x in + Option_Some (hoist16 .+ (ret_both (10 : int32))) + else Option_Some (ret_both (0 : int32)) in + Option_Some (letb b := ret_both (20 : int32) in + Option_Some (a .+ b)))) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32). +Fail Next Obligation. + +Equations direct_result_question_mark {L1 : {fset Location}} {I1 : Interface} (y : both L1 I1 (t_Result 'unit int32)) : both L1 I1 (t_Result int8 int32) := + direct_result_question_mark y := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := y in + Result_Ok (Result_Ok (ret_both (0 : int8))))) : both L1 I1 (t_Result int8 int32). +Fail Next Obligation. + +Equations direct_result_question_mark_coercion {L1 : {fset Location}} {I1 : Interface} (y : both L1 I1 (t_Result int8 int16)) : both L1 I1 (t_Result int8 int32) := + direct_result_question_mark_coercion y := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] hoist17 := impl__map_err y f_from in + Result_Ok (Result_Ok hoist17))) : both L1 I1 (t_Result int8 int32). +Fail Next Obligation. + +Equations options {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I1 : Interface} {I2 : Interface} {I3 : Interface} (x : both L1 I1 (t_Option int8)) (y : both L2 I2 (t_Option int8)) (z : both L3 I3 (t_Option int64)) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (t_Option int8) := + options x y z := + solve_lift (run (letm[choice_typeMonad.option_bind_code] hoist21 := x in + letb hoist22 := hoist21 >.? (ret_both (10 : int8)) in + letm[choice_typeMonad.option_bind_code] hoist28 := ifb hoist22 + then letm[choice_typeMonad.option_bind_code] hoist23 := x in + Option_Some (letb hoist24 := impl_u8__wrapping_add hoist23 (ret_both (3 : int8)) in + Option_Some hoist24) + else letm[choice_typeMonad.option_bind_code] hoist26 := x in + letm[choice_typeMonad.option_bind_code] hoist25 := y in + Option_Some (letb hoist27 := impl_u8__wrapping_add hoist26 hoist25 in + Option_Some hoist27) in + letm[choice_typeMonad.option_bind_code] hoist29 := hoist28 in + letm[choice_typeMonad.option_bind_code] v := matchb hoist29 with + | 3 => + Option_None + | 4 => + letm[choice_typeMonad.option_bind_code] hoist18 := z in + Option_Some (letb hoist19 := hoist18 >.? (ret_both (4 : int64)) in + letb hoist20 := ifb hoist19 + then ret_both (0 : int8) + else ret_both (3 : int8) in + solve_lift ((ret_both (4 : int8)) .+ hoist20)) + | _ => + Option_Some (solve_lift (ret_both (12 : int8))) + end in + letm[choice_typeMonad.option_bind_code] hoist30 := x in + letb hoist32 := impl_u8__wrapping_add v hoist30 in + letm[choice_typeMonad.option_bind_code] hoist31 := y in + Option_Some (letb hoist33 := impl_u8__wrapping_add hoist32 hoist31 in + Option_Some hoist33))) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (t_Option int8). +Fail Next Obligation. + +Equations question_mark {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int32) : both L1 I1 (t_Result int32 int32) := + question_mark x := + solve_lift (run (letm[choice_typeMonad.result_bind_code int32] _ := ifb x >.? (ret_both (40 : int32)) + then letb y loc(y_loc) := ret_both (0 : int32) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb hoist34 := x >.? (ret_both (90 : int32)) in + ifb hoist34 + then impl__map_err (Result_Err (ret_both (12 : int8))) f_from + else () + else () in + Result_Ok (Result_Ok (impl_u32__wrapping_add (ret_both (3 : int32)) x)))) : both L1 I1 (t_Result int32 int32). +Fail Next Obligation. + +Definition t_A : choice_type := + 'unit. +Equations Build_t_A : both (fset []) (fset []) (t_A) := + Build_t_A := + solve_lift (ret_both (tt (* Empty tuple *) : (t_A))) : both (fset []) (fset []) (t_A). +Fail Next Obligation. + +Definition t_B : choice_type := + 'unit. +Equations Build_t_B : both (fset []) (fset []) (t_B) := + Build_t_B := + solve_lift (ret_both (tt (* Empty tuple *) : (t_B))) : both (fset []) (fset []) (t_B). +Fail Next Obligation. + +Equations monad_lifting {L1 : {fset Location}} {I1 : Interface} (x : both L1 I1 int8) : both L1 I1 (t_Result t_A t_B) := + monad_lifting x := + solve_lift (run (ifb x >.? (ret_both (123 : int8)) + then letm[choice_typeMonad.result_bind_code (t_Result t_A t_B)] hoist35 := ControlFlow_Continue (Result_Err B) in + letb hoist36 := Result_Ok hoist35 in + letm[choice_typeMonad.result_bind_code (t_Result t_A t_B)] hoist37 := ControlFlow_Break hoist36 in + ControlFlow_Continue (never_to_any hoist37) + else ControlFlow_Continue (Result_Ok A))) : both L1 I1 (t_Result t_A t_B). +Fail Next Obligation. + +Definition t_Bar : choice_type := + ('bool × nseq ('bool × 'bool) 6 × 'bool). +Equations f_a {L : {fset Location}} {I : Interface} (s : both L I t_Bar) : both L I 'bool := + f_a s := + bind_both s (fun x => + solve_lift (ret_both (fst x : 'bool))) : both L I 'bool. +Fail Next Obligation. +Equations f_b {L : {fset Location}} {I : Interface} (s : both L I t_Bar) : both L I (nseq ('bool × 'bool) 6 × 'bool) := + f_b s := + bind_both s (fun x => + solve_lift (ret_both (snd x : (nseq ('bool × 'bool) 6 × 'bool)))) : both L I (nseq ('bool × 'bool) 6 × 'bool). +Fail Next Obligation. +Equations Build_t_Bar {L0 : {fset Location}} {L1 : {fset Location}} {I0 : Interface} {I1 : Interface} {f_a : both L0 I0 'bool} {f_b : both L1 I1 (nseq ('bool × 'bool) 6 × 'bool)} : both (L0:|:L1) (I0:|:I1) (t_Bar) := + Build_t_Bar := + bind_both f_b (fun f_b => + bind_both f_a (fun f_a => + solve_lift (ret_both ((f_a,f_b) : (t_Bar))))) : both (L0:|:L1) (I0:|:I1) (t_Bar). +Fail Next Obligation. +Notation "'Build_t_Bar' '[' x ']' '(' 'f_a' ':=' y ')'" := (Build_t_Bar (f_a := y) (f_b := f_b x)). +Notation "'Build_t_Bar' '[' x ']' '(' 'f_b' ':=' y ')'" := (Build_t_Bar (f_a := f_a x) (f_b := y)). + +Definition t_Foo : choice_type := + ('bool × 'bool × t_Vec t_Bar t_Global × nseq t_Bar 6 × t_Bar). +Equations f_x {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I 'bool := + f_x s := + bind_both s (fun x => + solve_lift (ret_both (fst (fst (fst x)) : 'bool))) : both L I 'bool. +Fail Next Obligation. +Equations f_y {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I ('bool × t_Vec t_Bar t_Global) := + f_y s := + bind_both s (fun x => + solve_lift (ret_both (snd (fst (fst x)) : ('bool × t_Vec t_Bar t_Global)))) : both L I ('bool × t_Vec t_Bar t_Global). +Fail Next Obligation. +Equations f_z {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I (nseq t_Bar 6) := + f_z s := + bind_both s (fun x => + solve_lift (ret_both (snd (fst x) : (nseq t_Bar 6)))) : both L I (nseq t_Bar 6). +Fail Next Obligation. +Equations f_bar {L : {fset Location}} {I : Interface} (s : both L I t_Foo) : both L I t_Bar := + f_bar s := + bind_both s (fun x => + solve_lift (ret_both (snd x : t_Bar))) : both L I t_Bar. +Fail Next Obligation. +Equations Build_t_Foo {L0 : {fset Location}} {L1 : {fset Location}} {L2 : {fset Location}} {L3 : {fset Location}} {I0 : Interface} {I1 : Interface} {I2 : Interface} {I3 : Interface} {f_x : both L0 I0 'bool} {f_y : both L1 I1 ('bool × t_Vec t_Bar t_Global)} {f_z : both L2 I2 (nseq t_Bar 6)} {f_bar : both L3 I3 t_Bar} : both (L0:|:L1:|:L2:|:L3) (I0:|:I1:|:I2:|:I3) (t_Foo) := + Build_t_Foo := + bind_both f_bar (fun f_bar => + bind_both f_z (fun f_z => + bind_both f_y (fun f_y => + bind_both f_x (fun f_x => + solve_lift (ret_both ((f_x,f_y,f_z,f_bar) : (t_Foo))))))) : both (L0:|:L1:|:L2:|:L3) (I0:|:I1:|:I2:|:I3) (t_Foo). +Fail Next Obligation. +Notation "'Build_t_Foo' '[' x ']' '(' 'f_x' ':=' y ')'" := (Build_t_Foo (f_x := y) (f_y := f_y x) (f_z := f_z x) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_y' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := y) (f_z := f_z x) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_z' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := f_y x) (f_z := y) (f_bar := f_bar x)). +Notation "'Build_t_Foo' '[' x ']' '(' 'f_bar' ':=' y ')'" := (Build_t_Foo (f_x := f_x x) (f_y := f_y x) (f_z := f_z x) (f_bar := y)). + +Equations assign_non_trivial_lhs {L1 : {fset Location}} {I1 : Interface} (foo : both L1 I1 t_Foo) : both L1 I1 t_Foo := + assign_non_trivial_lhs foo := + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + letb _ := assign todo(term) in + solve_lift foo : both L1 I1 t_Foo. +Fail Next Obligation. + +(*Not implemented yet? todo(item)*) + +Equations test {L1 : {fset Location}} {L2 : {fset Location}} {I1 : Interface} {I2 : Interface} (x : both L1 I1 (t_Option int32)) (y : both L2 I2 (t_Option int32)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32) := + test x y := + solve_lift (run (letb hoist40 := fun i => + letm[choice_typeMonad.option_bind_code] hoist38 := y in + Option_Some (letb hoist39 := i .+ hoist38 in + Option_Some hoist39) in + letb hoist41 := impl__map x hoist40 in + hoist41)) : both (L1 :|: L2) (I1 :|: I2) (t_Option int32). +Fail Next Obligation. ''' diff --git a/test-harness/src/snapshots/toolchain__slices into-coq.snap b/test-harness/src/snapshots/toolchain__slices into-coq.snap index 93fa425b0..b409063aa 100644 --- a/test-harness/src/snapshots/toolchain__slices into-coq.snap +++ b/test-harness/src/snapshots/toolchain__slices into-coq.snap @@ -54,5 +54,5 @@ Definition r#unsized (_ : t_Array (t_Slice t_u8) (1)) : unit := tt. Definition sized (x : t_Array (t_Array (t_u8) (4)) (1)) : unit := - r#unsized ([unsize (index (x) (0))]). + r#unsized ([unsize (f_index (x) (0))]). ''' diff --git a/test-harness/src/snapshots/toolchain__traits into-fstar.snap b/test-harness/src/snapshots/toolchain__traits into-fstar.snap index 13804827f..100f98304 100644 --- a/test-harness/src/snapshots/toolchain__traits into-fstar.snap +++ b/test-harness/src/snapshots/toolchain__traits into-fstar.snap @@ -80,8 +80,7 @@ open Core open FStar.Mul let original_function_from_495_ (list: Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global) : Prims.unit = - let (v__indices: Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global):Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global - = + let (e_indices: Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global):Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global = Core.Iter.Traits.Iterator.f_collect #(Core.Iter.Adapters.Filter.t_Filter (Core.Ops.Range.t_Range u8) (u8 -> bool)) #FStar.Tactics.Typeclasses.solve @@ -133,8 +132,7 @@ let minimized_1_ (list: Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global) let minimized_2_ (it: Core.Iter.Adapters.Filter.t_Filter (Core.Ops.Range.t_Range u8) (u8 -> bool)) : Prims.unit = - let (v__indices: Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global):Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global - = + let (e_indices: Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global):Alloc.Vec.t_Vec u8 Alloc.Alloc.t_Global = Core.Iter.Traits.Iterator.f_collect #(Core.Iter.Adapters.Filter.t_Filter (Core.Ops.Range.t_Range u8) (u8 -> bool)) #FStar.Tactics.Typeclasses.solve @@ -155,7 +153,7 @@ class t_Foo (v_Self: Type0) (v_T: Type0) = { f_to_t:x0: v_Self -> Prims.Pure v_T (f_to_t_pre x0) (fun result -> f_to_t_post x0 result) } -let v__f (#v_X: Type0) (#[FStar.Tactics.Typeclasses.tcresolve ()] i1: t_Foo v_X u8) (x: v_X) +let e_f (#v_X: Type0) (#[FStar.Tactics.Typeclasses.tcresolve ()] i1: t_Foo v_X u8) (x: v_X) : Prims.unit = let _:u8 = f_to_t #v_X #u8 #FStar.Tactics.Typeclasses.solve x in () @@ -334,7 +332,7 @@ let impl (#v_TypeArg: Type0) (v_ConstArg: usize) : t_Trait Prims.unit v_TypeArg (fun (#v_MethodTypeArg: Type0) (v_MethodConstArg: usize) - (v__self: Prims.unit) + (e_self: Prims.unit) (value_TypeArg: v_TypeArg) (value_Type: t_Type v_TypeArg v_ConstArg) -> @@ -344,7 +342,7 @@ let impl (#v_TypeArg: Type0) (v_ConstArg: usize) : t_Trait Prims.unit v_TypeArg (fun (#v_MethodTypeArg: Type0) (v_MethodConstArg: usize) - (v__self: Prims.unit) + (e_self: Prims.unit) (value_TypeArg: v_TypeArg) (value_Type: t_Type v_TypeArg v_ConstArg) (out: Prims.unit) @@ -355,7 +353,7 @@ let impl (#v_TypeArg: Type0) (v_ConstArg: usize) : t_Trait Prims.unit v_TypeArg fun (#v_MethodTypeArg: Type0) (v_MethodConstArg: usize) - (v__self: Prims.unit) + (e_self: Prims.unit) (value_TypeArg: v_TypeArg) (value_Type: t_Type v_TypeArg v_ConstArg) -> @@ -530,7 +528,7 @@ let impl: t_PolyOp t_Plus = type t_Times = | Times : t_Times [@@ FStar.Tactics.Typeclasses.tcinstance] -let impl_1: t_PolyOp t_Times = +let impl_PolyOp_for_Times: t_PolyOp t_Times = { f_op_pre = (fun (x: u32) (y: u32) -> true); f_op_post = (fun (x: u32) (y: u32) (out: u32) -> true); @@ -559,12 +557,12 @@ class t_SuperTrait (v_Self: Type0) = { } [@@ FStar.Tactics.Typeclasses.tcinstance] -let impl_SuperTrait_for_i32: t_SuperTrait i32 = +let impl: t_SuperTrait i32 = { _super_9529721400157967266 = FStar.Tactics.Typeclasses.solve; f_function_of_super_trait_pre = (fun (self: i32) -> true); f_function_of_super_trait_post = (fun (self: i32) (out: u32) -> true); - f_function_of_super_trait = fun (self: i32) -> cast (Core.Num.impl__i32__abs self <: i32) <: u32 + f_function_of_super_trait = fun (self: i32) -> cast (Core.Num.impl_i32__abs self <: i32) <: u32 } type t_Struct = | Struct : t_Struct @@ -612,7 +610,7 @@ type t_Error = | Error_Fail : t_Error let t_Error_cast_to_repr (x: t_Error) : isize = match x <: t_Error with | Error_Fail -> mk_isize 0 -let impl__Error__for_application_callback (_: Prims.unit) : Prims.unit -> t_Error = +let impl_Error__for_application_callback (_: Prims.unit) : Prims.unit -> t_Error = fun temp_0_ -> let _:Prims.unit = temp_0_ in Error_Fail <: t_Error @@ -622,7 +620,7 @@ let iter_option (#v_T: Type0) (x: Core.Option.t_Option v_T) : Core.Option.t_Into #FStar.Tactics.Typeclasses.solve (Core.Option.impl__as_ref #v_T x <: Core.Option.t_Option v_T) -let use_impl_trait (_: Prims.unit) : Prims.unit = +let uuse_iimpl_trait (_: Prims.unit) : Prims.unit = let iter:_ = iter_option #bool (Core.Option.Option_Some false <: Core.Option.t_Option bool) in let tmp0, out:(_ & Core.Option.t_Option bool) = Core.Iter.Traits.Iterator.f_next #_ #FStar.Tactics.Typeclasses.solve iter From da3eeaa78c8f85cac52303486206cc458a7bf520 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Wed, 29 Jan 2025 16:42:37 +0100 Subject: [PATCH 18/21] Adapt core lib to new naming. --- proof-libs/fstar/core/Core.Num.fsti | 90 +++++++++---------- proof-libs/fstar/core/Core.Ops.Arith.Neg.fsti | 4 - proof-libs/fstar/core/Core.Ops.Arith.fsti | 2 +- .../rust_primitives/Rust_primitives.Hax.fst | 4 + .../fstar/rust_primitives/Rust_primitives.fst | 5 -- 5 files changed, 50 insertions(+), 55 deletions(-) delete mode 100644 proof-libs/fstar/core/Core.Ops.Arith.Neg.fsti diff --git a/proof-libs/fstar/core/Core.Num.fsti b/proof-libs/fstar/core/Core.Num.fsti index 4b9c2cb8d..2521af35f 100644 --- a/proof-libs/fstar/core/Core.Num.fsti +++ b/proof-libs/fstar/core/Core.Num.fsti @@ -1,60 +1,60 @@ module Core.Num open Rust_primitives -let impl__u16__MAX: u16 = mk_u16 (maxint u16_inttype) +let impl_u16__MAX: u16 = mk_u16 (maxint u16_inttype) -let impl__u8__wrapping_add: u8 -> u8 -> u8 = add_mod -let impl__u8__wrapping_sub: u8 -> u8 -> u8 = sub_mod -let impl__u16__wrapping_add: u16 -> u16 -> u16 = add_mod -val impl__u16__to_be_bytes: u16 -> t_Array u8 (sz 2) -val impl__u16__from_be_bytes: t_Array u8 (sz 2) -> u16 -let impl__i32__wrapping_add: i32 -> i32 -> i32 = add_mod -let impl__i32__abs (a:i32{minint i32_inttype < v a}) : i32 = abs_int a +let impl_u8__wrapping_add: u8 -> u8 -> u8 = add_mod +let impl_u8__wrapping_sub: u8 -> u8 -> u8 = sub_mod +let impl_u16__wrapping_add: u16 -> u16 -> u16 = add_mod +val impl_u16__to_be_bytes: u16 -> t_Array u8 (sz 2) +val impl_u16__from_be_bytes: t_Array u8 (sz 2) -> u16 +let impl_i32__wrapping_add: i32 -> i32 -> i32 = add_mod +let impl_i32__abs (a:i32{minint i32_inttype < v a}) : i32 = abs_int a -let impl__i16__wrapping_add: i16 -> i16 -> i16 = add_mod -let impl__i16__wrapping_sub: i16 -> i16 -> i16 = sub_mod -let impl__i16__wrapping_mul: i16 -> i16 -> i16 = mul_mod +let impl_i16__wrapping_add: i16 -> i16 -> i16 = add_mod +let impl_i16__wrapping_sub: i16 -> i16 -> i16 = sub_mod +let impl_i16__wrapping_mul: i16 -> i16 -> i16 = mul_mod -let impl__u32__wrapping_add: u32 -> u32 -> u32 = add_mod -val impl__u32__rotate_left: u32 -> u32 -> u32 -val impl__u32__from_le_bytes: t_Array u8 (sz 4) -> u32 -val impl__u32__from_be_bytes: t_Array u8 (sz 4) -> u32 -val impl__u32__to_le_bytes: u32 -> t_Array u8 (sz 4) -val impl__u32__to_be_bytes: u32 -> t_Array u8 (sz 4) -val impl__u32__rotate_right: u32 -> u32 -> u32 -let impl__u32__BITS: u32 = mk_int 32 +let impl_u32__wrapping_add: u32 -> u32 -> u32 = add_mod +val impl_u32__rotate_left: u32 -> u32 -> u32 +val impl_u32__from_le_bytes: t_Array u8 (sz 4) -> u32 +val impl_u32__from_be_bytes: t_Array u8 (sz 4) -> u32 +val impl_u32__to_le_bytes: u32 -> t_Array u8 (sz 4) +val impl_u32__to_be_bytes: u32 -> t_Array u8 (sz 4) +val impl_u32__rotate_right: u32 -> u32 -> u32 +let impl_u32__BITS: u32 = mk_int 32 -let impl__u64__wrapping_add: u64 -> u64 -> u64 = add_mod -val impl__u64__rotate_left: u32 -> u32 -> u32 -val impl__u64__from_le_bytes: t_Array u8 (sz 8) -> u64 -val impl__u64__from_be_bytes: t_Array u8 (sz 8) -> u64 -val impl__u64__to_le_bytes: u64 -> t_Array u8 (sz 8) -val impl__u64__to_be_bytes: u64 -> t_Array u8 (sz 8) -val impl__u64__rotate_right: u64 -> u64 -> u64 +let impl_u64__wrapping_add: u64 -> u64 -> u64 = add_mod +val impl_u64__rotate_left: u32 -> u32 -> u32 +val impl_u64__from_le_bytes: t_Array u8 (sz 8) -> u64 +val impl_u64__from_be_bytes: t_Array u8 (sz 8) -> u64 +val impl_u64__to_le_bytes: u64 -> t_Array u8 (sz 8) +val impl_u64__to_be_bytes: u64 -> t_Array u8 (sz 8) +val impl_u64__rotate_right: u64 -> u64 -> u64 -let impl__u128__wrapping_add: u128 -> u128 -> u128 = add_mod -val impl__u128__rotate_left: u128 -> u128 -> u128 -val impl__u128__from_le_bytes: t_Array u8 (sz 16) -> u128 -val impl__u128__from_be_bytes: t_Array u8 (sz 16) -> u128 -val impl__u128__to_le_bytes: u128 -> t_Array u8 (sz 16) -val impl__u128__to_be_bytes: u128 -> t_Array u8 (sz 16) -val impl__u128__rotate_right: u128 -> u128 -> u128 +let impl_u128__wrapping_add: u128 -> u128 -> u128 = add_mod +val impl_u128__rotate_left: u128 -> u128 -> u128 +val impl_u128__from_le_bytes: t_Array u8 (sz 16) -> u128 +val impl_u128__from_be_bytes: t_Array u8 (sz 16) -> u128 +val impl_u128__to_le_bytes: u128 -> t_Array u8 (sz 16) +val impl_u128__to_be_bytes: u128 -> t_Array u8 (sz 16) +val impl_u128__rotate_right: u128 -> u128 -> u128 -val impl__u8__pow: u8 -> u32 -> u8 -val impl__u16__pow (base: u16) (exponent: u32): result : u16 {v base == 2 /\ v exponent < 16 ==> result == mk_u16 (pow2 (v exponent))} -val impl__u32__pow (base: u32) (exponent: u32): result : u32 {v base == 2 /\ v exponent <= 16 ==> result == mk_u32 (pow2 (v exponent))} -val impl__u64__pow: u64 -> u32 -> u64 -val impl__u128__pow: u128 -> u32 -> u128 -val impl__i16__pow (base: i16) (exponent: u32): result: i16 {v base == 2 /\ v exponent < 15 ==> (Math.Lemmas.pow2_lt_compat 15 (v exponent); result == mk_i16 (pow2 (v exponent)))} -val impl__i32__pow (base: i32) (exponent: u32): result: i32 {v base == 2 /\ v exponent <= 16 ==> result == mk_i32 (pow2 (v exponent))} +val impl_u8__pow: u8 -> u32 -> u8 +val impl_u16__pow (base: u16) (exponent: u32): result : u16 {v base == 2 /\ v exponent < 16 ==> result == mk_u16 (pow2 (v exponent))} +val impl_u32__pow (base: u32) (exponent: u32): result : u32 {v base == 2 /\ v exponent <= 16 ==> result == mk_u32 (pow2 (v exponent))} +val impl_u64__pow: u64 -> u32 -> u64 +val impl_u128__pow: u128 -> u32 -> u128 +val impl_i16__pow (base: i16) (exponent: u32): result: i16 {v base == 2 /\ v exponent < 15 ==> (Math.Lemmas.pow2_lt_compat 15 (v exponent); result == mk_i16 (pow2 (v exponent)))} +val impl_i32__pow (base: i32) (exponent: u32): result: i32 {v base == 2 /\ v exponent <= 16 ==> result == mk_i32 (pow2 (v exponent))} -val impl__u8__count_ones: u8 -> r:u32{v r <= 8} -val impl__i32__count_ones: i32 -> r:u32{v r <= 32} +val impl_u8__count_ones: u8 -> r:u32{v r <= 8} +val impl_i32__count_ones: i32 -> r:u32{v r <= 32} -val impl__u8__from_str_radix: string -> u32 -> Core.Result.t_Result u8 Core.Num.Error.t_ParseIntError +val impl_u8__from_str_radix: string -> u32 -> Core.Result.t_Result u8 Core.Num.Error.t_ParseIntError -val impl__usize__ilog2: i32 -> u32 -val impl__usize__leading_zeros: usize -> u32 +val impl_usize__ilog2: i32 -> u32 +val impl_usize__leading_zeros: usize -> u32 open Core.Ops.Arith unfold instance add_assign_num_refined_refined t ($phi1 $phi2: int_t t -> bool) diff --git a/proof-libs/fstar/core/Core.Ops.Arith.Neg.fsti b/proof-libs/fstar/core/Core.Ops.Arith.Neg.fsti deleted file mode 100644 index a72ecb4f0..000000000 --- a/proof-libs/fstar/core/Core.Ops.Arith.Neg.fsti +++ /dev/null @@ -1,4 +0,0 @@ -module Core.Ops.Arith.Neg -open Rust_primitives - -let neg #t x = zero #t -! x diff --git a/proof-libs/fstar/core/Core.Ops.Arith.fsti b/proof-libs/fstar/core/Core.Ops.Arith.fsti index db0911455..9d4071fa0 100644 --- a/proof-libs/fstar/core/Core.Ops.Arith.fsti +++ b/proof-libs/fstar/core/Core.Ops.Arith.fsti @@ -58,4 +58,4 @@ class t_DivAssign self rhs = { f_div_assign: x:self -> y:rhs -> Pure self (f_div_assign_pre x y) (fun r -> f_div_assign_post x y r); } - +let f_neg #t x = zero #t -! x diff --git a/proof-libs/fstar/rust_primitives/Rust_primitives.Hax.fst b/proof-libs/fstar/rust_primitives/Rust_primitives.Hax.fst index cf0198303..68ab01d2c 100644 --- a/proof-libs/fstar/rust_primitives/Rust_primitives.Hax.fst +++ b/proof-libs/fstar/rust_primitives/Rust_primitives.Hax.fst @@ -63,3 +63,7 @@ class iterator_return (self: Type u#0): Type u#1 = { parent_iterator: Core.Iter.Traits.Iterator.iterator self; f_fold_return: #b:Type0 -> s:self -> b -> (b -> i:parent_iterator.f_Item{parent_iterator.f_contains s i} -> Core.Ops.Control_flow.t_ControlFlow b b) -> Core.Ops.Control_flow.t_ControlFlow b b; } +let rec while_loop #s (condition: s -> bool) (init: s) (f: (i:s -> o:s{o << i})): s + = if condition init + then while_loop #s condition (f init) f + else init diff --git a/proof-libs/fstar/rust_primitives/Rust_primitives.fst b/proof-libs/fstar/rust_primitives/Rust_primitives.fst index 2037912ef..bfc9722e2 100644 --- a/proof-libs/fstar/rust_primitives/Rust_primitives.fst +++ b/proof-libs/fstar/rust_primitives/Rust_primitives.fst @@ -49,8 +49,3 @@ instance array_to_slice_unsize t n: unsize_tc (t_Array t n) = { unsize = (fun (arr: t_Array t n) -> arr <: t_Slice t); } - -let rec f_while_loop #s (condition: s -> bool) (init: s) (f: (i:s -> o:s{o << i})): s - = if condition init - then f_while_loop #s condition (f init) f - else init From 4335f706406924a85705f4ebb6393cf090853e9f Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Thu, 30 Jan 2025 10:07:44 +0100 Subject: [PATCH 19/21] Better documentation for new naming. --- engine/lib/concrete_ident/concrete_ident.ml | 14 ++++++-------- engine/lib/concrete_ident/concrete_ident.mli | 5 +++-- engine/lib/concrete_ident/concrete_ident_view.ml | 12 +++++++----- .../concrete_ident/concrete_ident_view_types.ml | 12 ++++++------ engine/lib/concrete_ident/explicit_def_id.ml | 2 +- engine/lib/concrete_ident/explicit_def_id.mli | 10 +++++----- engine/lib/concrete_ident/impl_infos.ml | 2 +- 7 files changed, 29 insertions(+), 28 deletions(-) diff --git a/engine/lib/concrete_ident/concrete_ident.ml b/engine/lib/concrete_ident/concrete_ident.ml index e36aa0aad..98660e97e 100644 --- a/engine/lib/concrete_ident/concrete_ident.ml +++ b/engine/lib/concrete_ident/concrete_ident.ml @@ -184,7 +184,7 @@ let to_view (ident : t) : Concrete_ident_view.t = in { mod_path; rel_path } -(** Stateful store that maps [def_id]s to implementation informations +(** Stateful store that maps [def_id]s to implementation information (which trait is implemented? for which type? under which constraints?) *) module ImplInfoStore = struct include Explicit_def_id.ImplInfoStore @@ -195,18 +195,16 @@ end module MakeToString (R : VIEW_RENDERER) = struct open Concrete_ident_render_sig - (** For each module namespace, we store three different pieces of data: - - a map from relative paths (i.e. the non-module part of a path) to full - identifiers - - an set of rendered names in this namespace + (** For each module namespace, we store two different pieces of data: + - a set of rendered names in this namespace - a memoization map from full identifiers to rendered names If an identifier was already rendered, we just use this already rendered name. Otherwise, when we print a name under a fresh module, we take a look at - the first map: if there is already an identifier in the fresh module with - the exact same relative path, then we have a collision, and we need to + the set: if there is already an identifier in the fresh module with + the exact same rendered name, then we have a collision, and we need to generate a fresh name. To generate a fresh name, we use the set of rendered names. @@ -466,7 +464,7 @@ module MakeRenderAPI (NP : NAME_POLICY) : RENDER_API = struct else rendered end - (** [pretty_impl_name ~namespace impl_infos] computes a pretty impl name given impl informations and a namespace. + (** [pretty_impl_name ~namespace impl_infos] computes a pretty impl name given impl information and a namespace. A pretty name can be computed when: - (1) the impl, (2) the type and (3) the trait implemented all live in the same namespace - the impl block has no generics diff --git a/engine/lib/concrete_ident/concrete_ident.mli b/engine/lib/concrete_ident/concrete_ident.mli index 037d4dde7..d44f7b80c 100644 --- a/engine/lib/concrete_ident/concrete_ident.mli +++ b/engine/lib/concrete_ident/concrete_ident.mli @@ -47,7 +47,7 @@ val eq_name : name -> t -> bool (** [eq_name name identifier] is true whenever [identifier] is [name]. *) val to_debug_string : t -> string -(** Format a identifier as a (ppx) debug string. The default debug pretty prints the identifier. *) +(** Format an identifier as a (ppx) debug string. The default debug pretty prints the identifier. *) val fresh_module : label:string -> t list -> Fresh_module.t (** [fresh_module ~label hints] creates a fresh module given a non-empty list of @@ -72,6 +72,7 @@ val map_path_strings : f:(string -> string) -> t -> t any integer type, please do not use it elsewhere. *) val is_constructor : t -> bool +(** Returns true if the ident represents a constructor. *) type comparator_witness @@ -90,7 +91,7 @@ module ImplInfoStore : sig val init : (Types.def_id * Types.impl_infos) list -> unit val lookup_raw : t -> Types.impl_infos option - (** Lookup the (raw[1]) implementation informations given a concrete + (** Lookup the (raw[1]) implementation information given a concrete ident. Returns `Some _` if and only if the supplied identifier points to an `Impl`. diff --git a/engine/lib/concrete_ident/concrete_ident_view.ml b/engine/lib/concrete_ident/concrete_ident_view.ml index 35bd07a23..aebffa98f 100644 --- a/engine/lib/concrete_ident/concrete_ident_view.ml +++ b/engine/lib/concrete_ident/concrete_ident_view.ml @@ -1,10 +1,10 @@ open! Prelude include Concrete_ident_view_types -(** Rust paths comes with invariants (e.g. a function is always a `ValueNs _`), this function raises an error if a path doesn't respect those. *) +(** Rust paths come with invariants (e.g. a function is always a `ValueNs _`), this function raises an error if a path doesn't respect those. *) let broken_invariant (type t) msg (did : Explicit_def_id.t) : t = let msg = - "Explicit_def_id: an invariant have been broken. Expected " ^ msg + "Explicit_def_id: an invariant has been broken. Expected " ^ msg ^ ".\n\ndid=" ^ [%show: Explicit_def_id.t] did in @@ -131,8 +131,8 @@ let rec poly : | SyntheticCoroutineBody -> (* It should be impossible for such items to ever be referenced by anyting in hax. *) broken_invariant - "non (TyAlias | TyParam | ConstParam | InlineConst | LifetimeParam | \ - Closure | SyntheticCoroutineBody) identifier" + "non (TyParam | ConstParam | InlineConst | LifetimeParam | Closure | \ + SyntheticCoroutineBody) identifier" did in result @@ -156,7 +156,7 @@ let of_def_id (did : Explicit_def_id.t) : t = (Explicit_def_id.parents did |> List.rev) in *) (* `rest` is a list of identifiers of items nested each in the others. *) - (* We want to process those items begining with most nested one. *) + (* We want to process those items beginning with most nested one. *) (* let rest = List.rev rest in *) (* We distinguish between: - a chain of identifiers that have a relation with each other (e.g. if `k::E::C` is a constructor and `k::E` a enum) @@ -200,6 +200,8 @@ let of_def_id (did : Explicit_def_id.t) : t = "A `Mod` identifier must a `TypeNs` as its last path" m) ns_chunks in + (* This is a hack: we remove a prefix that we add in + https://github.com/cryspen/hax/blob/02d67770f2626e4bb27fc2a1ba9cfe612819d4a8/hax-lib/macros/src/implementation.rs#L897 *) let mod_path = List.filter mod_path ~f:(fun ds -> String.is_prefix ds.data ~prefix:"hax__autogenerated_refinement_" |> not) diff --git a/engine/lib/concrete_ident/concrete_ident_view_types.ml b/engine/lib/concrete_ident/concrete_ident_view_types.ml index 8235737a9..14b651b5f 100644 --- a/engine/lib/concrete_ident/concrete_ident_view_types.ml +++ b/engine/lib/concrete_ident/concrete_ident_view_types.ml @@ -2,19 +2,19 @@ open! Prelude (** This modules defines what is the view over a concrete identifiers. - Hax manipulates concrete identifiers (that is global identifiers refering to + Hax manipulates concrete identifiers (that is global identifiers referring to concrete Rust items -- not built-in operators) as raw Rust identifiers augmented with some metadata. Rust represents identifiers as a crate and a path. Each chunk of the path is - roughly a level of nest in Rust. The path lacks informations about + roughly a level of nest in Rust. The path lacks information about definition kinds. There is two kinds of nesting for items. - - Confort: e.g. the user decides to embed a struct within a function to work + - Comfort: e.g. the user decides to embed a struct within a function to work with it locally. - Relational: e.g. an associated method has to be under a trait, or a field - as to be under a constructor. + has to be under a constructor. This module provides a view to those paths: a path in the view is a list of smaller relational paths. For instance, consider the following piece of @@ -33,7 +33,7 @@ open! Prelude ]} Here, the Rust raw definition identifier of [LocalStruct] is roughly - [a::my_crate::::assoc_fn::LocalStruct::field]. + [my_crate::a::::assoc_fn::LocalStruct::field]. The view for [LocalStruct] looks like: [{ @@ -102,7 +102,7 @@ module RelPath = struct and 'name maybe_associated = [ `Fn of 'name | `Const of 'name ] [@@deriving show, hash, compare, sexp, hash, eq, map] - (** Helper type for function and constants: those exists both as associated + (** Helper type for function and constants: those exist both as associated in an impl block or a trait, and as standalone. *) type 'name associated = [ 'name maybe_associated | `Type of 'name ] diff --git a/engine/lib/concrete_ident/explicit_def_id.ml b/engine/lib/concrete_ident/explicit_def_id.ml index 2bc176b7c..579126f7c 100644 --- a/engine/lib/concrete_ident/explicit_def_id.ml +++ b/engine/lib/concrete_ident/explicit_def_id.ml @@ -90,7 +90,7 @@ let rec parents (did : t) = let to_def_id { def_id; _ } = def_id let is_constructor { is_constructor; _ } = is_constructor -(** Stateful store that maps [def_id]s to implementation informations +(** Stateful store that maps [def_id]s to implementation information (which trait is implemented? for which type? under which constraints?) *) module ImplInfoStore = struct let state : (Types.def_id_contents, Types.impl_infos) Hashtbl.t option ref = diff --git a/engine/lib/concrete_ident/explicit_def_id.mli b/engine/lib/concrete_ident/explicit_def_id.mli index ba67d86d1..e8c56d6c6 100644 --- a/engine/lib/concrete_ident/explicit_def_id.mli +++ b/engine/lib/concrete_ident/explicit_def_id.mli @@ -8,8 +8,8 @@ open! Prelude struct S; fn f() -> S { S } ``` - Here, the return type of `f` (that is, `S`) and the constructor `S` in the body of `f` refers to the exact same identifier `mycrate::S`. - Yet, they denotes two very different objects: a type versus a constructor. + Here, the return type of `f` (that is, `S`) and the constructor `S` in the body of `f` refer to the exact same identifier `mycrate::S`. + Yet, they denote two very different objects: a type versus a constructor. [ExplicitDefId.t] clears up this ambiguity, making constructors and types two separate things. @@ -32,9 +32,9 @@ val of_def_id : ?constructor:bool -> Types.def_id -> t option *) val of_def_id_exn : ?constructor:bool -> Types.def_id -> t -(** Exception-throwing variant of [make]. +(** Exception-throwing variant of [of_def_id]. This should be used when we know statically that the conditions - described in the documentation of [make] are met. + described in the documentation of [of_def_id] are met. For instance, with static [Types.def_id]s or in [Import_thir]. *) @@ -70,7 +70,7 @@ module ImplInfoStore : sig val init : (Types.def_id * Types.impl_infos) list -> unit val lookup_raw : t -> Types.impl_infos option - (** Lookup the (raw[1]) implementation informations given a concrete + (** Lookup the (raw[1]) implementation information given a concrete ident. Returns `Some _` if and only if the supplied identifier points to an `Impl`. diff --git a/engine/lib/concrete_ident/impl_infos.ml b/engine/lib/concrete_ident/impl_infos.ml index 995cc1a16..8d819cba7 100644 --- a/engine/lib/concrete_ident/impl_infos.ml +++ b/engine/lib/concrete_ident/impl_infos.ml @@ -11,7 +11,7 @@ type t = { } (** metadata of an [impl] block *) -(** Lookup the implementation informations given a concrete +(** Lookup the implementation information given a concrete ident. Returns [Some _] if and only if the supplied identifier points to an [Impl]. From 0eb63e5f5868169af0a1c2353fa4f81f0a1b6e26 Mon Sep 17 00:00:00 2001 From: Lucas Franceschino Date: Thu, 30 Jan 2025 10:54:51 +0100 Subject: [PATCH 20/21] misc(engine): drop stale comment --- engine/lib/concrete_ident/concrete_ident_view.ml | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/engine/lib/concrete_ident/concrete_ident_view.ml b/engine/lib/concrete_ident/concrete_ident_view.ml index aebffa98f..fad6f7a61 100644 --- a/engine/lib/concrete_ident/concrete_ident_view.ml +++ b/engine/lib/concrete_ident/concrete_ident_view.ml @@ -145,19 +145,6 @@ let view_name_did : Explicit_def_id.t -> _ RelPath.Chunk.poly = poly ~into_n:mk ~into_d:mk let of_def_id (did : Explicit_def_id.t) : t = - (* Decompose the parents of a Explicit_def_id, say `a::b::c::d::e`, into: - - `ns_chunks`, the module parents `[a; a::b]` and into - - `rest`, the remaining parents `[a::b::c; a::b::c::d; a::b::c::d::e]` the rest. *) - (* let ns_chunks, rest = - List.split_while - ~f: - ( Explicit_def_id.to_def_id >> fun def_id -> - match def_id.kind with Mod -> true | _ -> false ) - (Explicit_def_id.parents did |> List.rev) - in *) - (* `rest` is a list of identifiers of items nested each in the others. *) - (* We want to process those items beginning with most nested one. *) - (* let rest = List.rev rest in *) (* We distinguish between: - a chain of identifiers that have a relation with each other (e.g. if `k::E::C` is a constructor and `k::E` a enum) - a chain of identifiers that have no relation (e.g. `k::f` and `k::f::g` are both functions). From 051c4ebbd3400e7c00bf850764ad61012afa7058 Mon Sep 17 00:00:00 2001 From: Maxime Buyse Date: Thu, 30 Jan 2025 13:29:52 +0100 Subject: [PATCH 21/21] Fix proverif backend with new naming. --- engine/backends/proverif/proverif_backend.ml | 5 ++--- .../deprecated_generic_printer.ml | 5 ++--- .../deprecated_generic_printer_base.ml | 6 +++--- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/engine/backends/proverif/proverif_backend.ml b/engine/backends/proverif/proverif_backend.ml index 159aad007..0466e79af 100644 --- a/engine/backends/proverif/proverif_backend.ml +++ b/engine/backends/proverif/proverif_backend.ml @@ -651,9 +651,8 @@ module Make (Options : OPTS) : MAKE = struct fun id -> if under_current_ns then print#name_of_concrete_ident id else - let crate, path = print#namespace_of_concrete_ident id in - let full_path = crate :: path in - separate_map (underscore ^^ underscore) utf8string full_path + let path = print#namespace_of_concrete_ident id in + separate_map (underscore ^^ underscore) utf8string path ^^ underscore ^^ underscore ^^ print#name_of_concrete_ident id diff --git a/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml index 4b52400d7..4374e47a4 100644 --- a/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml +++ b/engine/lib/deprecated_generic_printer/deprecated_generic_printer.ml @@ -29,11 +29,10 @@ module Make (F : Features.T) (View : Concrete_ident.RENDER_API) = struct AlreadyPar | _ -> NeedsPar - method namespace_of_concrete_ident - : concrete_ident -> string * string list = + method namespace_of_concrete_ident : concrete_ident -> string list = fun i -> let rendered = View.render i in - (rendered.name, rendered.path) + rendered.path method concrete_ident' ~(under_current_ns : bool) : concrete_ident fn = fun id -> diff --git a/engine/lib/deprecated_generic_printer/deprecated_generic_printer_base.ml b/engine/lib/deprecated_generic_printer/deprecated_generic_printer_base.ml index 780ce2bcf..8f53c39f3 100644 --- a/engine/lib/deprecated_generic_printer/deprecated_generic_printer_base.ml +++ b/engine/lib/deprecated_generic_printer/deprecated_generic_printer_base.ml @@ -88,7 +88,7 @@ module Make (F : Features.T) = struct object (print) val mutable current_span = Span.default val mutable span_data : Annotation.t list = [] - val mutable current_namespace : (string * string list) option = None + val mutable current_namespace : string list option = None method get_span_data () = span_data method with_span ~span f = @@ -118,7 +118,7 @@ module Make (F : Features.T) = struct let id_ns = print#namespace_of_concrete_ident id in print#concrete_ident' ~under_current_ns: - ([%equal: (string * string list) option] current_ns (Some id_ns)) + ([%equal: string list option] current_ns (Some id_ns)) id (** Print a concrete identifier. @@ -281,7 +281,7 @@ module Make (F : Features.T) = struct method printer_name : string method get_span_data : unit -> Annotation.t list - method namespace_of_concrete_ident : concrete_ident -> string * string list + method namespace_of_concrete_ident : concrete_ident -> string list (** The namespace a concrete identifier was defined in. *) method par_state : ast_position -> par_state