diff options
165 files changed, 25447 insertions, 13077 deletions
@@ -27,7 +27,7 @@ CHARON_TESTS_POLONIUS_DIR ?= $(CHARON_HOME)/tests-polonius # The path to the Aeneas executable to run the tests - we need the ability to # change this path for the Nix package. -AENEAS_EXE ?= bin/aeneas.exe +AENEAS_EXE ?= bin/aeneas # The user can specify additional translation options for Aeneas. # By default we do: @@ -71,9 +71,12 @@ build-lib: .PHONY: build-bin-dir build-bin-dir: build-driver build-lib mkdir -p bin - cp -f compiler/_build/default/driver.exe bin/aeneas.exe + cp -f compiler/_build/default/driver.exe bin/aeneas cp -f compiler/_build/default/driver.exe bin/aeneas.cmxs - cp -rf backends bin + mkdir -p bin/backends/fstar + mkdir -p bin/backends/coq + cp -rf backends/fstar/*.fst* bin/backends/fstar/ + cp -rf backends/coq/*.v bin/backends/coq/ .PHONY: doc doc: @@ -85,13 +88,13 @@ clean: # Test the project by translating test files to F* .PHONY: tests -tests: trans-no_nested_borrows trans-paper \ - trans-hashmap trans-hashmap_main \ - trans-external trans-constants \ - transp-polonius_list transp-betree_main \ - test-transp-betree_main \ - trans-loops \ - trans-array # TODO: generalize to all backends +tests: test-no_nested_borrows test-paper \ + test-hashmap test-hashmap_main \ + test-external test-constants \ + testp-polonius_list testp-betree_main \ + ctest-testp-betree_main \ + test-loops \ + test-array test-traits # TODO: generalize to all backends # Verify the F* files generated by the translation .PHONY: verify @@ -114,51 +117,65 @@ AENEAS_CMD = $(AENEAS_EXE) $(CHARON_TEST_DIR)/llbc/$(FILE).llbc -dest tests/$(BA # Add specific options to some tests -trans-no_nested_borrows trans-paper: \ - OPTIONS += -test-units -test-trans-units -no-split-files -no-state -trans-no_nested_borrows trans-paper: SUBDIR := misc +test-no_nested_borrows test-paper: \ + OPTIONS += -test-trans-units +test-no_nested_borrows test-paper: SUBDIR := misc tfstar-no_nested_borrows tfstar-paper: tlean-no_nested_borrows: SUBDIR := tlean-paper: SUBDIR := thol4-no_nested_borrows: SUBDIR := misc-no_nested_borrows thol4-paper: SUBDIR := misc-paper -trans-array: OPTIONS += -no-state -trans-array: SUBDIR := array -tfstar-array: OPTIONS += -decreases-clauses -template-clauses +test-array: OPTIONS += +test-array: SUBDIR := array +tfstar-array: OPTIONS += -decreases-clauses -template-clauses -split-files tcoq-array: OPTIONS += -use-fuel tlean-array: SUBDIR := tlean-array: OPTIONS += thol4-array: OPTIONS += +test-traits: OPTIONS += +test-traits: SUBDIR := traits +tfstar-traits: OPTIONS += -decreases-clauses -template-clauses +tcoq-traits: OPTIONS += +tlean-traits: SUBDIR := +tlean-traits: OPTIONS += +thol4-traits: OPTIONS += + # TODO: activate the arrays for all the backends thol4-array: echo "Ignoring the array test for HOL4" -trans-loops: OPTIONS += -no-state -trans-loops: SUBDIR := misc -tfstar-loops: OPTIONS += -decreases-clauses -template-clauses -tcoq-loops: OPTIONS += -use-fuel -no-split-files +# TODO: activate the traits for all the backends +thol4-traits: + echo "Ignoring the traits test for HOL4" + +test-loops: OPTIONS += +test-loops: SUBDIR := misc +tfstar-loops: OPTIONS += -decreases-clauses -template-clauses -split-files +tcoq-loops: OPTIONS += -use-fuel tlean-loops: SUBDIR := thol4-loops: SUBDIR := misc-loops -trans-hashmap: OPTIONS += -no-state -test-trans-units -trans-hashmap: SUBDIR := hashmap +# TODO: reactivate -test-trans-units +test-hashmap: OPTIONS += -split-files +test-hashmap: SUBDIR := hashmap tfstar-hashmap: OPTIONS += -decreases-clauses -template-clauses tcoq-hashmap: OPTIONS += -use-fuel tlean-hashmap: SUBDIR := tlean-hashmap: OPTIONS += -no-gen-lib-entry # We add a custom import in the Hashmap.lean file: we do not want to overwrite it thol4-hashmap: OPTIONS += -trans-hashmap_main: OPTIONS += -test-trans-units -trans-hashmap_main: SUBDIR := hashmap_on_disk +# TODO: reactivate -test-trans-units +test-hashmap_main: OPTIONS += -state -split-files +test-hashmap_main: SUBDIR := hashmap_on_disk tfstar-hashmap_main: OPTIONS += -decreases-clauses -template-clauses tcoq-hashmap_main: OPTIONS += -use-fuel tlean-hashmap_main: SUBDIR := thol4-hashmap_main: OPTIONS += -transp-polonius_list: OPTIONS += -test-units -test-trans-units -no-split-files -no-state -transp-polonius_list: SUBDIR := misc +testp-polonius_list: OPTIONS += -test-trans-units +testp-polonius_list: SUBDIR := misc tfstarp-polonius_list: OPTIONS += tcoqp-polonius_list: OPTIONS += tleanp-polonius_list: SUBDIR := @@ -166,8 +183,8 @@ tleanp-polonius_list: OPTIONS += thol4p-polonius_list: SUBDIR := misc-polonius_list thol4p-polonius_list: OPTIONS += -trans-constants: OPTIONS += -test-units -test-trans-units -no-split-files -no-state -trans-constants: SUBDIR := misc +test-constants: OPTIONS += -test-trans-units +test-constants: SUBDIR := misc tfstar-constants: OPTIONS += tcoq-constants: OPTIONS += tlean-constants: SUBDIR := @@ -175,8 +192,8 @@ tlean-constants: OPTIONS += thol4-constants: SUBDIR := misc-constants thol4-constants: OPTIONS += -trans-external: OPTIONS += -test-trans-units -trans-external: SUBDIR := misc +test-external: OPTIONS += -test-trans-units -state -split-files +test-external: SUBDIR := misc tfstar-external: OPTIONS += tcoq-external: OPTIONS += tlean-external: SUBDIR := @@ -185,25 +202,25 @@ thol4-external: SUBDIR := misc-external thol4-external: OPTIONS += BETREE_FSTAR_OPTIONS = -decreases-clauses -template-clauses -transp-betree_main: OPTIONS += -backward-no-state-update -test-trans-units -transp-betree_main: SUBDIR:=betree +testp-betree_main: OPTIONS += -backward-no-state-update -test-trans-units -state -split-files +testp-betree_main: SUBDIR:=betree tfstarp-betree_main: OPTIONS += $(BETREE_FSTAR_OPTIONS) tcoqp-betree_main: OPTIONS += -use-fuel tleanp-betree_main: SUBDIR := tleanp-betree_main: OPTIONS += thol4-betree_main: OPTIONS += -# Additional test on the betree: translate it without `-backward-no-state-update`. +# Additional, *c*ustom test on the betree: translate it without `-backward-no-state-update`. # This generates very ugly code, but is good to test the translation. -.PHONY: test-transp-betree_main -test-transp-betree_main: transp-betree_main -test-transp-betree_main: OPTIONS += -backend fstar -test-trans-units -test-transp-betree_main: OPTIONS += $(BETREE_FSTAR_OPTIONS) -test-transp-betree_main: BACKEND_SUBDIR := "fstar" -test-transp-betree_main: SUBDIR:=betree_back_stateful -test-transp-betree_main: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) -test-transp-betree_main: FILE = betree_main -test-transp-betree_main: +.PHONY: ctest-testp-betree_main +ctest-testp-betree_main: testp-betree_main +ctest-testp-betree_main: OPTIONS += -backend fstar -test-trans-units -state -split-files +ctest-testp-betree_main: OPTIONS += $(BETREE_FSTAR_OPTIONS) +ctest-testp-betree_main: BACKEND_SUBDIR := "fstar" +ctest-testp-betree_main: SUBDIR:=betree_back_stateful +ctest-testp-betree_main: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) +ctest-testp-betree_main: FILE = betree_main +ctest-testp-betree_main: $(AENEAS_CMD) # Generic rules to extract the LLBC from a rust file @@ -220,20 +237,20 @@ gen-llbcp-%: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) gen-llbcp-%: $(CHARON_CMD) -# Generic rules to test the translation of an LLBC file. +# Generic rules to test the testlation of an LLBC file. # Note that the files requiring the Polonius borrow-checker are generated # in the tests-polonius subdirectory. -.PHONY: trans-% -trans-%: CHARON_TEST_DIR = $(CHARON_TESTS_REGULAR_DIR) -trans-%: FILE = $* -trans-%: gen-llbc-% tfstar-% tcoq-% tlean-% thol4-% +.PHONY: test-% +test-%: CHARON_TEST_DIR = $(CHARON_TESTS_REGULAR_DIR) +test-%: FILE = $* +test-%: gen-llbc-% tfstar-% tcoq-% tlean-% thol4-% echo "# Test $* done" # "p" stands for "Polonius" -.PHONY: transp-% -transp-%: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) -transp-%: FILE = $* -transp-%: gen-llbcp-% tfstarp-% tcoqp-% tleanp-% thol4p-% +.PHONY: testp-% +testp-%: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) +testp-%: FILE = $* +testp-%: gen-llbcp-% tfstarp-% tcoqp-% tleanp-% thol4p-% echo "# Test $* done" .PHONY: tfstar-% @@ -276,17 +293,25 @@ tleanp-%: BACKEND_SUBDIR := lean tleanp-%: $(AENEAS_CMD) +# TODO: reactivate HOL4 once traits are parameterized by their associated types .PHONY: thol4-% thol4-%: OPTIONS += -backend hol4 thol4-%: BACKEND_SUBDIR := hol4 thol4-%: - $(AENEAS_CMD) + echo Ignoring the $* test for HOL4 +#thol4-%: +# $(AENEAS_CMD) + +# TODO: reactivate HOL4 once traits are parameterized by their associated types .PHONY: thol4p-% thol4p-%: OPTIONS += -backend hol4 thol4p-%: BACKEND_SUBDIR := hol4 thol4p-%: - $(AENEAS_CMD) + echo Ignoring the $* test for HOL4 + +#thol4p-%: +# $(AENEAS_CMD) # Nix - TODO: add the lean tests .PHONY: nix diff --git a/backends/coq/Primitives.v b/backends/coq/Primitives.v index 71a2d9c3..85e38f01 100644 --- a/backends/coq/Primitives.v +++ b/backends/coq/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -394,12 +396,89 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -419,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -474,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. +Definition alloc_vec_Vec_insert_fwd (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result unit := + if to_Z i <? alloc_vec_Vec_length v then Return tt else Fail_ Failure. -Definition vec_insert_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i <? Z.of_nat (length l) then Return (list_update l (usize_to_nat i) x) else Fail_ Failure). -(* The **backward** function shouldn't be used *) -Definition vec_index_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. - -(* The **backward** function shouldn't be used *) -Definition vec_index_mut_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i <? Z.of_nat (length l) - then Return (list_update l (usize_to_nat i) x) - else Fail_ Failure). +(* [core::slice::index::Range:::get]: forward function *) +Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: forward function *) +Axiom core_slice_index_Range_get_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index 9db82069..3297803c 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -169,17 +187,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize @@ -231,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -259,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -278,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -295,55 +389,54 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -358,18 +451,279 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/backends/hol4/primitivesScript.sml b/backends/hol4/primitivesScript.sml index 82da4de9..916988be 100644 --- a/backends/hol4/primitivesScript.sml +++ b/backends/hol4/primitivesScript.sml @@ -555,6 +555,32 @@ Proof QED val _ = evalLib.add_unfold_thm "mk_isize_unfold" +(** Constants *) +val core_i8_min_def = Define ‘core_i8_min = int_to_i8 i8_min’ +val core_i8_max_def = Define ‘core_i8_max = int_to_i8 i8_max’ +val core_i16_min_def = Define ‘core_i16_min = int_to_i16 i16_min’ +val core_i16_max_def = Define ‘core_i16_max = int_to_i16 i16_max’ +val core_i32_min_def = Define ‘core_i32_min = int_to_i32 i32_min’ +val core_i32_max_def = Define ‘core_i32_max = int_to_i32 i32_max’ +val core_i64_min_def = Define ‘core_i64_min = int_to_i64 i64_min’ +val core_i64_max_def = Define ‘core_i64_max = int_to_i64 i64_max’ +val core_i128_min_def = Define ‘core_i128_min = int_to_i128 i128_min’ +val core_i128_max_def = Define ‘core_i128_max = int_to_i128 i128_max’ +val core_isize_min_def = Define ‘core_isize_min = int_to_isize isize_min’ +val core_isize_max_def = Define ‘core_isize_max = int_to_isize isize_max’ +val core_u8_min_def = Define ‘core_u8_min = int_to_u8 0’ +val core_u8_max_def = Define ‘core_u8_max = int_to_u8 u8_max’ +val core_u16_min_def = Define ‘core_u16_min = int_to_u16 0’ +val core_u16_max_def = Define ‘core_u16_max = int_to_u16 u16_max’ +val core_u32_min_def = Define ‘core_u32_min = int_to_u32 0’ +val core_u32_max_def = Define ‘core_u32_max = int_to_u32 u32_max’ +val core_u64_min_def = Define ‘core_u64_min = int_to_u64 0’ +val core_u64_max_def = Define ‘core_u64_max = int_to_u64 u64_max’ +val core_u128_min_def = Define ‘core_u128_min = int_to_u128 0’ +val core_u128_max_def = Define ‘core_u128_max = int_to_u128 u128_max’ +val core_usize_min_def = Define ‘core_usize_min = int_to_usize 0’ +val core_usize_max_def = Define ‘core_usize_max = int_to_usize usize_max’ + val isize_neg_def = Define ‘isize_neg x = mk_isize (- (isize_to_int x))’ val i8_neg_def = Define ‘i8_neg x = mk_i8 (- (i8_to_int x))’ val i16_neg_def = Define ‘i16_neg x = mk_i16 (- (i16_to_int x))’ diff --git a/backends/hol4/primitivesTheory.sig b/backends/hol4/primitivesTheory.sig index 6660b02d..4ae6bb3e 100644 --- a/backends/hol4/primitivesTheory.sig +++ b/backends/hol4/primitivesTheory.sig @@ -46,6 +46,30 @@ sig (* Definitions *) val bind_def : thm + val core_i128_max_def : thm + val core_i128_min_def : thm + val core_i16_max_def : thm + val core_i16_min_def : thm + val core_i32_max_def : thm + val core_i32_min_def : thm + val core_i64_max_def : thm + val core_i64_min_def : thm + val core_i8_max_def : thm + val core_i8_min_def : thm + val core_isize_max_def : thm + val core_isize_min_def : thm + val core_u128_max_def : thm + val core_u128_min_def : thm + val core_u16_max_def : thm + val core_u16_min_def : thm + val core_u32_max_def : thm + val core_u32_min_def : thm + val core_u64_max_def : thm + val core_u64_min_def : thm + val core_u8_max_def : thm + val core_u8_min_def : thm + val core_usize_max_def : thm + val core_usize_min_def : thm val error_BIJ : thm val error_CASE : thm val error_TY_DEF : thm @@ -566,6 +590,102 @@ sig monad_bind x f = case x of Return y => f y | Fail e => Fail e | Diverge => Diverge + [core_i128_max_def] Definition + + ⊢ core_i128_max = int_to_i128 i128_max + + [core_i128_min_def] Definition + + ⊢ core_i128_min = int_to_i128 i128_min + + [core_i16_max_def] Definition + + ⊢ core_i16_max = int_to_i16 i16_max + + [core_i16_min_def] Definition + + ⊢ core_i16_min = int_to_i16 i16_min + + [core_i32_max_def] Definition + + ⊢ core_i32_max = int_to_i32 i32_max + + [core_i32_min_def] Definition + + ⊢ core_i32_min = int_to_i32 i32_min + + [core_i64_max_def] Definition + + ⊢ core_i64_max = int_to_i64 i64_max + + [core_i64_min_def] Definition + + ⊢ core_i64_min = int_to_i64 i64_min + + [core_i8_max_def] Definition + + ⊢ core_i8_max = int_to_i8 i8_max + + [core_i8_min_def] Definition + + ⊢ core_i8_min = int_to_i8 i8_min + + [core_isize_max_def] Definition + + ⊢ core_isize_max = int_to_isize isize_max + + [core_isize_min_def] Definition + + ⊢ core_isize_min = int_to_isize isize_min + + [core_u128_max_def] Definition + + ⊢ core_u128_max = int_to_u128 u128_max + + [core_u128_min_def] Definition + + ⊢ core_u128_min = int_to_u128 0 + + [core_u16_max_def] Definition + + ⊢ core_u16_max = int_to_u16 u16_max + + [core_u16_min_def] Definition + + ⊢ core_u16_min = int_to_u16 0 + + [core_u32_max_def] Definition + + ⊢ core_u32_max = int_to_u32 u32_max + + [core_u32_min_def] Definition + + ⊢ core_u32_min = int_to_u32 0 + + [core_u64_max_def] Definition + + ⊢ core_u64_max = int_to_u64 u64_max + + [core_u64_min_def] Definition + + ⊢ core_u64_min = int_to_u64 0 + + [core_u8_max_def] Definition + + ⊢ core_u8_max = int_to_u8 u8_max + + [core_u8_min_def] Definition + + ⊢ core_u8_min = int_to_u8 0 + + [core_usize_max_def] Definition + + ⊢ core_usize_max = int_to_usize usize_max + + [core_usize_min_def] Definition + + ⊢ core_usize_min = int_to_usize 0 + [error_BIJ] Definition ⊢ (∀a. num2error (error2num a) = a) ∧ diff --git a/backends/lean/Base/Arith/Base.lean b/backends/lean/Base/Arith/Base.lean index 9c11ed45..8ada4171 100644 --- a/backends/lean/Base/Arith/Base.lean +++ b/backends/lean/Base/Arith/Base.lean @@ -57,4 +57,16 @@ theorem int_pos_ind (p : Int → Prop) : -- TODO: there is probably something more general to do theorem nat_zero_eq_int_zero : (0 : Nat) = (0 : Int) := by simp +-- This is mostly used in termination proofs +theorem to_int_to_nat_lt (x y : ℤ) (h0 : 0 ≤ x) (h1 : x < y) : + ↑(x.toNat) < y := by + simp [*] + +-- This is mostly used in termination proofs +theorem to_int_sub_to_nat_lt (x y : ℤ) (x' : ℕ) + (h0 : ↑x' ≤ x) (h1 : x - ↑x' < y) : + ↑(x.toNat - x') < y := by + have : 0 ≤ x := by linarith + simp [Int.toNat_sub_of_le, *] + end Arith diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index 3359ecdb..a57f8bb1 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -162,7 +162,7 @@ def introInstances (declToUnfold : Name) (lookup : Expr → MetaM (Option Expr)) -- Add a declaration let nval ← Utils.addDeclTac name e type (asLet := false) -- Simplify to unfold the declaration to unfold (i.e., the projector) - Utils.simpAt [declToUnfold] [] [] (Tactic.Location.targets #[mkIdent name] false) + Utils.simpAt true [declToUnfold] [] [] (Location.targets #[mkIdent name] false) -- Return the new value pure nval @@ -240,7 +240,7 @@ def intTac (splitGoalConjs : Bool) (extraPreprocess : Tactic.TacticM Unit) : Ta -- the goal. I think before leads to a smaller proof term? Tactic.allGoals (intTacPreprocess extraPreprocess) -- More preprocessing - Tactic.allGoals (Utils.tryTac (Utils.simpAt [] [``nat_zero_eq_int_zero] [] .wildcard)) + Tactic.allGoals (Utils.tryTac (Utils.simpAt true [] [``nat_zero_eq_int_zero] [] .wildcard)) -- Split the conjunctions in the goal if splitGoalConjs then Tactic.allGoals (Utils.repeatTac Utils.splitConjTarget) -- Call linarith @@ -270,6 +270,17 @@ elab "int_tac" args:(" split_goal"?): tactic => let split := args.raw.getArgs.size > 0 intTac split (do pure ()) +-- For termination proofs +syntax "int_decr_tac" : tactic +macro_rules + | `(tactic| int_decr_tac) => + `(tactic| + simp_wf; + -- TODO: don't use a macro (namespace problems) + (first | apply Arith.to_int_to_nat_lt + | apply Arith.to_int_sub_to_nat_lt) <;> + simp_all <;> int_tac) + example (x : Int) (h0: 0 ≤ x) (h1: x ≠ 0) : 0 < x := by int_tac_preprocess linarith diff --git a/backends/lean/Base/Arith/Scalar.lean b/backends/lean/Base/Arith/Scalar.lean index 47751c8a..2342cce6 100644 --- a/backends/lean/Base/Arith/Scalar.lean +++ b/backends/lean/Base/Arith/Scalar.lean @@ -17,7 +17,7 @@ def scalarTacExtraPreprocess : Tactic.TacticM Unit := do add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Usize []]) add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Isize []]) -- Reveal the concrete bounds, simplify calls to [ofInt] - Utils.simpAt [``Scalar.min, ``Scalar.max, ``Scalar.cMin, ``Scalar.cMax, + Utils.simpAt true [``Scalar.min, ``Scalar.max, ``Scalar.cMin, ``Scalar.cMax, ``I8.min, ``I16.min, ``I32.min, ``I64.min, ``I128.min, ``I8.max, ``I16.max, ``I32.max, ``I64.max, ``I128.max, ``U8.min, ``U16.min, ``U32.min, ``U64.min, ``U128.min, @@ -36,6 +36,17 @@ def scalarTac (splitGoalConjs : Bool) : Tactic.TacticM Unit := do elab "scalar_tac" : tactic => scalarTac false +-- For termination proofs +syntax "scalar_decr_tac" : tactic +macro_rules + | `(tactic| scalar_decr_tac) => + `(tactic| + simp_wf; + -- TODO: don't use a macro (namespace problems) + (first | apply Arith.to_int_to_nat_lt + | apply Arith.to_int_sub_to_nat_lt) <;> + simp_all <;> scalar_tac) + instance (ty : ScalarTy) : HasIntProp (Scalar ty) where -- prop_ty is inferred prop := λ x => And.intro x.hmin x.hmax diff --git a/backends/lean/Base/IList/IList.lean b/backends/lean/Base/IList/IList.lean index a940da25..f71f2de2 100644 --- a/backends/lean/Base/IList/IList.lean +++ b/backends/lean/Base/IList/IList.lean @@ -112,7 +112,13 @@ def pairwise_rel section Lemmas -variable {α : Type u} +variable {α : Type u} + +def ireplicate {α : Type u} (i : ℤ) (x : α) : List α := + if i ≤ 0 then [] + else x :: ireplicate (i - 1) x +termination_by ireplicate i x => i.toNat +decreasing_by int_decr_tac @[simp] theorem update_nil : update ([] : List α) i y = [] := by simp [update] @[simp] theorem update_zero_cons : update ((x :: tl) : List α) 0 y = y :: tl := by simp [update] @@ -129,6 +135,10 @@ variable {α : Type u} @[simp] theorem slice_nil : slice i j ([] : List α) = [] := by simp [slice] @[simp] theorem slice_zero : slice 0 0 (ls : List α) = [] := by cases ls <;> simp [slice] +@[simp] theorem ireplicate_zero : ireplicate 0 x = [] := by rw [ireplicate]; simp +@[simp] theorem ireplicate_nzero_cons (hne : 0 < i) : ireplicate i x = x :: ireplicate (i - 1) x := by + rw [ireplicate]; simp [*]; intro; linarith + @[simp] theorem slice_nzero_cons (i j : Int) (x : α) (tl : List α) (hne : i ≠ 0) : slice i j ((x :: tl) : List α) = slice (i - 1) (j - 1) tl := match tl with @@ -144,6 +154,33 @@ theorem slice_nzero_cons (i j : Int) (x : α) (tl : List α) (hne : i ≠ 0) : s conv at this => lhs; simp [slice, *] simp [*, slice] +@[simp] +theorem ireplicate_replicate {α : Type u} (l : ℤ) (x : α) (h : 0 ≤ l) : + ireplicate l x = replicate l.toNat x := + if hz: l = 0 then by + simp [*] + else by + have : 0 < l := by int_tac + have hr := ireplicate_replicate (l - 1) x (by int_tac) + simp [*] + have hl : l.toNat = .succ (l.toNat - 1) := by + cases hl: l.toNat <;> simp_all + conv => rhs; rw[hl] +termination_by ireplicate_replicate l x h => l.toNat +decreasing_by int_decr_tac + +@[simp] +theorem ireplicate_len {α : Type u} (l : ℤ) (x : α) (h : 0 ≤ l) : + (ireplicate l x).len = l := + if hz: l = 0 then by + simp [*] + else by + have : 0 < l := by int_tac + have hr := ireplicate_len (l - 1) x (by int_tac) + simp [*] +termination_by ireplicate_len l x h => l.toNat +decreasing_by int_decr_tac + theorem len_eq_length (ls : List α) : ls.len = ls.length := by induction ls . rfl diff --git a/backends/lean/Base/Primitives.lean b/backends/lean/Base/Primitives.lean index 6b7b0792..613b6076 100644 --- a/backends/lean/Base/Primitives.lean +++ b/backends/lean/Base/Primitives.lean @@ -1,4 +1,6 @@ import Base.Primitives.Base import Base.Primitives.Scalar -import Base.Primitives.Array +import Base.Primitives.ArraySlice import Base.Primitives.Vec +import Base.Primitives.Alloc +import Base.Primitives.CoreOps diff --git a/backends/lean/Base/Primitives/Alloc.lean b/backends/lean/Base/Primitives/Alloc.lean new file mode 100644 index 00000000..34590499 --- /dev/null +++ b/backends/lean/Base/Primitives/Alloc.lean @@ -0,0 +1,37 @@ +import Lean +import Base.Primitives.Base +import Base.Primitives.CoreOps + +open Primitives +open Result + +namespace alloc + +namespace boxed -- alloc.boxed + +namespace Box -- alloc.boxed.Box + +def deref (T : Type) (x : T) : Result T := ret x +def deref_mut (T : Type) (x : T) : Result T := ret x +def deref_mut_back (T : Type) (_ : T) (x : T) : Result T := ret x + +/-- Trait instance -/ +def coreOpsDerefInst (Self : Type) : + core.ops.deref.Deref Self := { + Target := Self + deref := deref Self +} + +/-- Trait instance -/ +def coreOpsDerefMutInst (Self : Type) : + core.ops.deref.DerefMut Self := { + derefInst := coreOpsDerefInst Self + deref_mut := deref_mut Self + deref_mut_back := deref_mut_back Self +} + +end Box -- alloc.boxed.Box + +end boxed -- alloc.boxed + +end alloc diff --git a/backends/lean/Base/Primitives/Array.lean b/backends/lean/Base/Primitives/Array.lean deleted file mode 100644 index 6c95fd78..00000000 --- a/backends/lean/Base/Primitives/Array.lean +++ /dev/null @@ -1,394 +0,0 @@ -/- Arrays/slices -/ -import Lean -import Lean.Meta.Tactic.Simp -import Init.Data.List.Basic -import Mathlib.Tactic.RunCmd -import Mathlib.Tactic.Linarith -import Base.IList -import Base.Primitives.Scalar -import Base.Primitives.Range -import Base.Arith -import Base.Progress.Base - -namespace Primitives - -open Result Error - -def Array (α : Type u) (n : Usize) := { l : List α // l.length = n.val } - -instance (a : Type u) (n : Usize) : Arith.HasIntProp (Array a n) where - prop_ty := λ v => v.val.len = n.val - prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] - -instance {α : Type u} {n : Usize} (p : Array α n → Prop) : Arith.HasIntProp (Subtype p) where - prop_ty := λ x => p x - prop := λ x => x.property - -@[simp] -abbrev Array.length {α : Type u} {n : Usize} (v : Array α n) : Int := v.val.len - -@[simp] -abbrev Array.v {α : Type u} {n : Usize} (v : Array α n) : List α := v.val - -example {α: Type u} {n : Usize} (v : Array α n) : v.length ≤ Scalar.max ScalarTy.Usize := by - scalar_tac - -def Array.make (α : Type u) (n : Usize) (init : List α) (hl : init.len = n.val := by decide) : - Array α n := ⟨ init, by simp [← List.len_eq_length]; apply hl ⟩ - -example : Array Int (Usize.ofInt 2) := Array.make Int (Usize.ofInt 2) [0, 1] - -@[simp] -abbrev Array.index {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i : Int) : α := - v.val.index i - -@[simp] -abbrev Array.slice {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i j : Int) : List α := - v.val.slice i j - -def Array.index_shared (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -/- In the theorems below: we don't always need the `∃ ..`, but we use one - so that `progress` introduces an opaque variable and an equality. This - helps control the context. - -/ - -@[pspec] -theorem Array.index_shared_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_shared α n i = ret x ∧ x = v.val.index i.val := by - simp only [index_shared] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - --- This shouldn't be used -def Array.index_shared_back (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (_: α) : Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - -def Array.index_mut (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -@[pspec] -theorem Array.index_mut_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_mut α n i = ret x ∧ x = v.val.index i.val := by - simp only [index_mut] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - -def Array.index_mut_back (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (x: α) : Result (Array α n) := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some _ => - .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ - -@[pspec] -theorem Array.index_mut_back_spec {α : Type u} {n : Usize} (v: Array α n) (i: Usize) (x : α) - (hbound : i.val < v.length) : - ∃ nv, v.index_mut_back α n i x = ret nv ∧ - nv.val = v.val.update i.val x - := by - simp only [index_mut_back] - have h := List.indexOpt_bounds v.val i.val - split - . simp_all [length]; cases h <;> scalar_tac - . simp_all - -def Slice (α : Type u) := { l : List α // l.length ≤ Usize.max } - -instance (a : Type u) : Arith.HasIntProp (Slice a) where - prop_ty := λ v => 0 ≤ v.val.len ∧ v.val.len ≤ Scalar.max ScalarTy.Usize - prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] - -instance {α : Type u} (p : Slice α → Prop) : Arith.HasIntProp (Subtype p) where - prop_ty := λ x => p x - prop := λ x => x.property - -@[simp] -abbrev Slice.length {α : Type u} (v : Slice α) : Int := v.val.len - -@[simp] -abbrev Slice.v {α : Type u} (v : Slice α) : List α := v.val - -example {a: Type u} (v : Slice a) : v.length ≤ Scalar.max ScalarTy.Usize := by - scalar_tac - -def Slice.new (α : Type u): Slice α := ⟨ [], by apply Scalar.cMax_suffices .Usize; simp ⟩ - --- TODO: very annoying that the α is an explicit parameter -def Slice.len (α : Type u) (v : Slice α) : Usize := - Usize.ofIntCore v.val.len (by scalar_tac) (by scalar_tac) - -@[simp] -theorem Slice.len_val {α : Type u} (v : Slice α) : (Slice.len α v).val = v.length := - by rfl - -@[simp] -abbrev Slice.index {α : Type u} [Inhabited α] (v: Slice α) (i: Int) : α := - v.val.index i - -@[simp] -abbrev Slice.slice {α : Type u} [Inhabited α] (s : Slice α) (i j : Int) : List α := - s.val.slice i j - -def Slice.index_shared (α : Type u) (v: Slice α) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -/- In the theorems below: we don't always need the `∃ ..`, but we use one - so that `progress` introduces an opaque variable and an equality. This - helps control the context. - -/ - -@[pspec] -theorem Slice.index_shared_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_shared α i = ret x ∧ x = v.val.index i.val := by - simp only [index_shared] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - --- This shouldn't be used -def Slice.index_shared_back (α : Type u) (v: Slice α) (i: Usize) (_: α) : Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - -def Slice.index_mut (α : Type u) (v: Slice α) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -@[pspec] -theorem Slice.index_mut_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_mut α i = ret x ∧ x = v.val.index i.val := by - simp only [index_mut] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - -def Slice.index_mut_back (α : Type u) (v: Slice α) (i: Usize) (x: α) : Result (Slice α) := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some _ => - .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ - -@[pspec] -theorem Slice.index_mut_back_spec {α : Type u} (v: Slice α) (i: Usize) (x : α) - (hbound : i.val < v.length) : - ∃ nv, v.index_mut_back α i x = ret nv ∧ - nv.val = v.val.update i.val x - := by - simp only [index_mut_back] - have h := List.indexOpt_bounds v.val i.val - split - . simp_all [length]; cases h <;> scalar_tac - . simp_all - -/- Array to slice/subslices -/ - -/- We could make this function not use the `Result` type. By making it monadic, we - push the user to use the `Array.to_slice_shared_spec` spec theorem below (through the - `progress` tactic), meaning `Array.to_slice_shared` should be considered as opaque. - All what the spec theorem reveals is that the "representative" lists are the same. -/ -def Array.to_slice_shared (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := - ret ⟨ v.val, by simp [← List.len_eq_length]; scalar_tac ⟩ - -@[pspec] -theorem Array.to_slice_shared_spec {α : Type u} {n : Usize} (v : Array α n) : - ∃ s, to_slice_shared α n v = ret s ∧ v.val = s.val := by simp [to_slice_shared] - -def Array.to_slice_mut (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := - to_slice_shared α n v - -@[pspec] -theorem Array.to_slice_mut_spec {α : Type u} {n : Usize} (v : Array α n) : - ∃ s, Array.to_slice_shared α n v = ret s ∧ v.val = s.val := to_slice_shared_spec v - -def Array.to_slice_mut_back (α : Type u) (n : Usize) (_ : Array α n) (s : Slice α) : Result (Array α n) := - if h: s.val.len = n.val then - ret ⟨ s.val, by simp [← List.len_eq_length, *] ⟩ - else fail panic - -@[pspec] -theorem Array.to_slice_mut_back_spec {α : Type u} {n : Usize} (a : Array α n) (ns : Slice α) (h : ns.val.len = n.val) : - ∃ na, to_slice_mut_back α n a ns = ret na ∧ na.val = ns.val - := by simp [to_slice_mut_back, *] - -def Array.subslice_shared (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := - -- TODO: not completely sure here - if r.start.val < r.end_.val ∧ r.end_.val ≤ a.val.len then - ret ⟨ a.val.slice r.start.val r.end_.val, - by - simp [← List.len_eq_length] - have := a.val.slice_len_le r.start.val r.end_.val - scalar_tac ⟩ - else - fail panic - -@[pspec] -theorem Array.subslice_shared_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : - ∃ s, subslice_shared α n a r = ret s ∧ - s.val = a.val.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) - := by - simp [subslice_shared, *] - intro i _ _ - have := List.index_slice r.start.val r.end_.val i a.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) - simp [*] - -def Array.subslice_mut (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := - Array.subslice_shared α n a r - -@[pspec] -theorem Array.subslice_mut_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : - ∃ s, subslice_mut α n a r = ret s ∧ - s.val = a.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) - := subslice_shared_spec a r h0 h1 - -def Array.subslice_mut_back (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) (s : Slice α) : Result (Array α n) := - -- TODO: not completely sure here - if h: r.start.val < r.end_.val ∧ r.end_.val ≤ a.length ∧ s.val.len = r.end_.val - r.start.val then - let s_beg := a.val.itake r.start.val - let s_end := a.val.idrop r.end_.val - have : s_beg.len = r.start.val := by - apply List.itake_len - . simp_all; scalar_tac - . scalar_tac - have : s_end.len = a.val.len - r.end_.val := by - apply List.idrop_len - . scalar_tac - . scalar_tac - let na := s_beg.append (s.val.append s_end) - have : na.len = a.val.len := by simp [*] - ret ⟨ na, by simp_all [← List.len_eq_length]; scalar_tac ⟩ - else - fail panic - --- TODO: it is annoying to write `.val` everywhere. We could leverage coercions, --- but: some symbols like `+` are already overloaded to be notations for monadic --- operations/ --- We should introduce special symbols for the monadic arithmetic operations --- (the use will never write those symbols directly). -@[pspec] -theorem Array.subslice_mut_back_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) (s : Slice α) - (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : s.length = r.end_.val - r.start.val) : - ∃ na, subslice_mut_back α n a r s = ret na ∧ - (∀ i, 0 ≤ i → i < r.start.val → na.index i = a.index i) ∧ - (∀ i, r.start.val ≤ i → i < r.end_.val → na.index i = s.index (i - r.start.val)) ∧ - (∀ i, r.end_.val ≤ i → i < n.val → na.index i = a.index i) := by - simp [subslice_mut_back, *] - have h := List.replace_slice_index r.start.val r.end_.val a.val s.val - (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) - simp [List.replace_slice] at h - have ⟨ h0, h1, h2 ⟩ := h - clear h - split_conjs - . intro i _ _ - have := h0 i (by int_tac) (by int_tac) - simp [*] - . intro i _ _ - have := h1 i (by int_tac) (by int_tac) - simp [*] - . intro i _ _ - have := h2 i (by int_tac) (by int_tac) - simp [*] - -def Slice.subslice_shared (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := - -- TODO: not completely sure here - if r.start.val < r.end_.val ∧ r.end_.val ≤ s.length then - ret ⟨ s.val.slice r.start.val r.end_.val, - by - simp [← List.len_eq_length] - have := s.val.slice_len_le r.start.val r.end_.val - scalar_tac ⟩ - else - fail panic - -@[pspec] -theorem Slice.subslice_shared_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : - ∃ ns, subslice_shared α s r = ret ns ∧ - ns.val = s.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index i = s.index (r.start.val + i)) - := by - simp [subslice_shared, *] - intro i _ _ - have := List.index_slice r.start.val r.end_.val i s.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) - simp [*] - -def Slice.subslice_mut (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := - Slice.subslice_shared α s r - -@[pspec] -theorem Slice.subslice_mut_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : - ∃ ns, subslice_mut α s r = ret ns ∧ - ns.val = s.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index i = s.index (r.start.val + i)) - := subslice_shared_spec s r h0 h1 - -attribute [pp_dot] List.len List.length List.index -- use the dot notation when printing -set_option pp.coercions false -- do not print coercions with ↑ (this doesn't parse) - -def Slice.subslice_mut_back (α : Type u) (s : Slice α) (r : Range Usize) (ss : Slice α) : Result (Slice α) := - -- TODO: not completely sure here - if h: r.start.val < r.end_.val ∧ r.end_.val ≤ s.length ∧ ss.val.len = r.end_.val - r.start.val then - let s_beg := s.val.itake r.start.val - let s_end := s.val.idrop r.end_.val - have : s_beg.len = r.start.val := by - apply List.itake_len - . simp_all; scalar_tac - . scalar_tac - have : s_end.len = s.val.len - r.end_.val := by - apply List.idrop_len - . scalar_tac - . scalar_tac - let ns := s_beg.append (ss.val.append s_end) - have : ns.len = s.val.len := by simp [*] - ret ⟨ ns, by simp_all [← List.len_eq_length]; scalar_tac ⟩ - else - fail panic - -@[pspec] -theorem Slice.subslice_mut_back_spec {α : Type u} [Inhabited α] (a : Slice α) (r : Range Usize) (ss : Slice α) - (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : ss.length = r.end_.val - r.start.val) : - ∃ na, subslice_mut_back α a r ss = ret na ∧ - (∀ i, 0 ≤ i → i < r.start.val → na.index i = a.index i) ∧ - (∀ i, r.start.val ≤ i → i < r.end_.val → na.index i = ss.index (i - r.start.val)) ∧ - (∀ i, r.end_.val ≤ i → i < a.length → na.index i = a.index i) := by - simp [subslice_mut_back, *] - have h := List.replace_slice_index r.start.val r.end_.val a.val ss.val - (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) - simp [List.replace_slice, *] at h - have ⟨ h0, h1, h2 ⟩ := h - clear h - split_conjs - . intro i _ _ - have := h0 i (by int_tac) (by int_tac) - simp [*] - . intro i _ _ - have := h1 i (by int_tac) (by int_tac) - simp [*] - . intro i _ _ - have := h2 i (by int_tac) (by int_tac) - simp [*] - -end Primitives diff --git a/backends/lean/Base/Primitives/ArraySlice.lean b/backends/lean/Base/Primitives/ArraySlice.lean new file mode 100644 index 00000000..cfc9a6b2 --- /dev/null +++ b/backends/lean/Base/Primitives/ArraySlice.lean @@ -0,0 +1,553 @@ +/- Arrays/Slices -/ +import Lean +import Lean.Meta.Tactic.Simp +import Init.Data.List.Basic +import Mathlib.Tactic.RunCmd +import Mathlib.Tactic.Linarith +import Base.IList +import Base.Primitives.Scalar +import Base.Primitives.Range +import Base.Primitives.CoreOps +import Base.Arith +import Base.Progress.Base + +namespace Primitives + +open Result Error core.ops.range + +def Array (α : Type u) (n : Usize) := { l : List α // l.length = n.val } + +instance (a : Type u) (n : Usize) : Arith.HasIntProp (Array a n) where + prop_ty := λ v => v.val.len = n.val + prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] + +instance {α : Type u} {n : Usize} (p : Array α n → Prop) : Arith.HasIntProp (Subtype p) where + prop_ty := λ x => p x + prop := λ x => x.property + +@[simp] +abbrev Array.length {α : Type u} {n : Usize} (v : Array α n) : Int := v.val.len + +@[simp] +abbrev Array.v {α : Type u} {n : Usize} (v : Array α n) : List α := v.val + +example {α: Type u} {n : Usize} (v : Array α n) : v.length ≤ Scalar.max ScalarTy.Usize := by + scalar_tac + +def Array.make (α : Type u) (n : Usize) (init : List α) (hl : init.len = n.val := by decide) : + Array α n := ⟨ init, by simp [← List.len_eq_length]; apply hl ⟩ + +example : Array Int (Usize.ofInt 2) := Array.make Int (Usize.ofInt 2) [0, 1] + +@[simp] +abbrev Array.index_s {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i : Int) : α := + v.val.index i + +@[simp] +abbrev Array.slice {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i j : Int) : List α := + v.val.slice i j + +def Array.index_usize (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some x => ret x + +-- For initialization +def Array.repeat (α : Type u) (n : Usize) (x : α) : Array α n := + ⟨ List.ireplicate n.val x, by have h := n.hmin; simp_all [Scalar.min] ⟩ + +@[pspec] +theorem Array.repeat_spec {α : Type u} (n : Usize) (x : α) : + ∃ a, Array.repeat α n x = a ∧ a.val = List.ireplicate n.val x := by + simp [Array.repeat] + +/- In the theorems below: we don't always need the `∃ ..`, but we use one + so that `progress` introduces an opaque variable and an equality. This + helps control the context. + -/ + +@[pspec] +theorem Array.index_usize_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) + (hbound : i.val < v.length) : + ∃ x, v.index_usize α n i = ret x ∧ x = v.val.index i.val := by + simp only [index_usize] + -- TODO: dependent rewrite + have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) + simp [*] + +def Array.update_usize (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (x: α) : Result (Array α n) := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some _ => + .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ + +@[pspec] +theorem Array.update_usize_spec {α : Type u} {n : Usize} (v: Array α n) (i: Usize) (x : α) + (hbound : i.val < v.length) : + ∃ nv, v.update_usize α n i x = ret nv ∧ + nv.val = v.val.update i.val x + := by + simp only [update_usize] + have h := List.indexOpt_bounds v.val i.val + split + . simp_all [length]; cases h <;> scalar_tac + . simp_all + +def Slice (α : Type u) := { l : List α // l.length ≤ Usize.max } + +instance (a : Type u) : Arith.HasIntProp (Slice a) where + prop_ty := λ v => 0 ≤ v.val.len ∧ v.val.len ≤ Scalar.max ScalarTy.Usize + prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] + +instance {α : Type u} (p : Slice α → Prop) : Arith.HasIntProp (Subtype p) where + prop_ty := λ x => p x + prop := λ x => x.property + +@[simp] +abbrev Slice.length {α : Type u} (v : Slice α) : Int := v.val.len + +@[simp] +abbrev Slice.v {α : Type u} (v : Slice α) : List α := v.val + +example {a: Type u} (v : Slice a) : v.length ≤ Scalar.max ScalarTy.Usize := by + scalar_tac + +def Slice.new (α : Type u): Slice α := ⟨ [], by apply Scalar.cMax_suffices .Usize; simp ⟩ + +-- TODO: very annoying that the α is an explicit parameter +def Slice.len (α : Type u) (v : Slice α) : Usize := + Usize.ofIntCore v.val.len (by scalar_tac) (by scalar_tac) + +@[simp] +theorem Slice.len_val {α : Type u} (v : Slice α) : (Slice.len α v).val = v.length := + by rfl + +@[simp] +abbrev Slice.index_s {α : Type u} [Inhabited α] (v: Slice α) (i: Int) : α := + v.val.index i + +@[simp] +abbrev Slice.slice {α : Type u} [Inhabited α] (s : Slice α) (i j : Int) : List α := + s.val.slice i j + +def Slice.index_usize (α : Type u) (v: Slice α) (i: Usize) : Result α := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some x => ret x + +/- In the theorems below: we don't always need the `∃ ..`, but we use one + so that `progress` introduces an opaque variable and an equality. This + helps control the context. + -/ + +@[pspec] +theorem Slice.index_usize_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) + (hbound : i.val < v.length) : + ∃ x, v.index_usize α i = ret x ∧ x = v.val.index i.val := by + simp only [index_usize] + -- TODO: dependent rewrite + have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) + simp [*] + +-- This shouldn't be used +def Slice.index_shared_back (α : Type u) (v: Slice α) (i: Usize) (_: α) : Result Unit := + if i.val < List.length v.val then + .ret () + else + .fail arrayOutOfBounds + +def Slice.update_usize (α : Type u) (v: Slice α) (i: Usize) (x: α) : Result (Slice α) := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some _ => + .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ + +@[pspec] +theorem Slice.update_usize_spec {α : Type u} (v: Slice α) (i: Usize) (x : α) + (hbound : i.val < v.length) : + ∃ nv, v.update_usize α i x = ret nv ∧ + nv.val = v.val.update i.val x + := by + simp only [update_usize] + have h := List.indexOpt_bounds v.val i.val + split + . simp_all [length]; cases h <;> scalar_tac + . simp_all + +/- Array to slice/subslices -/ + +/- We could make this function not use the `Result` type. By making it monadic, we + push the user to use the `Array.to_slice_spec` spec theorem below (through the + `progress` tactic), meaning `Array.to_slice` should be considered as opaque. + All what the spec theorem reveals is that the "representative" lists are the same. -/ +def Array.to_slice (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := + ret ⟨ v.val, by simp [← List.len_eq_length]; scalar_tac ⟩ + +@[pspec] +theorem Array.to_slice_spec {α : Type u} {n : Usize} (v : Array α n) : + ∃ s, to_slice α n v = ret s ∧ v.val = s.val := by simp [to_slice] + +def Array.from_slice (α : Type u) (n : Usize) (_ : Array α n) (s : Slice α) : Result (Array α n) := + if h: s.val.len = n.val then + ret ⟨ s.val, by simp [← List.len_eq_length, *] ⟩ + else fail panic + +@[pspec] +theorem Array.from_slice_spec {α : Type u} {n : Usize} (a : Array α n) (ns : Slice α) (h : ns.val.len = n.val) : + ∃ na, from_slice α n a ns = ret na ∧ na.val = ns.val + := by simp [from_slice, *] + +def Array.subslice (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := + -- TODO: not completely sure here + if r.start.val < r.end_.val ∧ r.end_.val ≤ a.val.len then + ret ⟨ a.val.slice r.start.val r.end_.val, + by + simp [← List.len_eq_length] + have := a.val.slice_len_le r.start.val r.end_.val + scalar_tac ⟩ + else + fail panic + +@[pspec] +theorem Array.subslice_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) + (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : + ∃ s, subslice α n a r = ret s ∧ + s.val = a.val.slice r.start.val r.end_.val ∧ + (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) + := by + simp [subslice, *] + intro i _ _ + have := List.index_slice r.start.val r.end_.val i a.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) + simp [*] + +def Array.update_subslice (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) (s : Slice α) : Result (Array α n) := + -- TODO: not completely sure here + if h: r.start.val < r.end_.val ∧ r.end_.val ≤ a.length ∧ s.val.len = r.end_.val - r.start.val then + let s_beg := a.val.itake r.start.val + let s_end := a.val.idrop r.end_.val + have : s_beg.len = r.start.val := by + apply List.itake_len + . simp_all; scalar_tac + . scalar_tac + have : s_end.len = a.val.len - r.end_.val := by + apply List.idrop_len + . scalar_tac + . scalar_tac + let na := s_beg.append (s.val.append s_end) + have : na.len = a.val.len := by simp [*] + ret ⟨ na, by simp_all [← List.len_eq_length]; scalar_tac ⟩ + else + fail panic + +-- TODO: it is annoying to write `.val` everywhere. We could leverage coercions, +-- but: some symbols like `+` are already overloaded to be notations for monadic +-- operations/ +-- We should introduce special symbols for the monadic arithmetic operations +-- (the use will never write those symbols directly). +@[pspec] +theorem Array.update_subslice_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) (s : Slice α) + (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : s.length = r.end_.val - r.start.val) : + ∃ na, update_subslice α n a r s = ret na ∧ + (∀ i, 0 ≤ i → i < r.start.val → na.index_s i = a.index_s i) ∧ + (∀ i, r.start.val ≤ i → i < r.end_.val → na.index_s i = s.index_s (i - r.start.val)) ∧ + (∀ i, r.end_.val ≤ i → i < n.val → na.index_s i = a.index_s i) := by + simp [update_subslice, *] + have h := List.replace_slice_index r.start.val r.end_.val a.val s.val + (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) + simp [List.replace_slice] at h + have ⟨ h0, h1, h2 ⟩ := h + clear h + split_conjs + . intro i _ _ + have := h0 i (by int_tac) (by int_tac) + simp [*] + . intro i _ _ + have := h1 i (by int_tac) (by int_tac) + simp [*] + . intro i _ _ + have := h2 i (by int_tac) (by int_tac) + simp [*] + +def Slice.subslice (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := + -- TODO: not completely sure here + if r.start.val < r.end_.val ∧ r.end_.val ≤ s.length then + ret ⟨ s.val.slice r.start.val r.end_.val, + by + simp [← List.len_eq_length] + have := s.val.slice_len_le r.start.val r.end_.val + scalar_tac ⟩ + else + fail panic + +@[pspec] +theorem Slice.subslice_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) + (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : + ∃ ns, subslice α s r = ret ns ∧ + ns.val = s.slice r.start.val r.end_.val ∧ + (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index_s i = s.index_s (r.start.val + i)) + := by + simp [subslice, *] + intro i _ _ + have := List.index_slice r.start.val r.end_.val i s.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) + simp [*] + +attribute [pp_dot] List.len List.length List.index -- use the dot notation when printing +set_option pp.coercions false -- do not print coercions with ↑ (this doesn't parse) + +def Slice.update_subslice (α : Type u) (s : Slice α) (r : Range Usize) (ss : Slice α) : Result (Slice α) := + -- TODO: not completely sure here + if h: r.start.val < r.end_.val ∧ r.end_.val ≤ s.length ∧ ss.val.len = r.end_.val - r.start.val then + let s_beg := s.val.itake r.start.val + let s_end := s.val.idrop r.end_.val + have : s_beg.len = r.start.val := by + apply List.itake_len + . simp_all; scalar_tac + . scalar_tac + have : s_end.len = s.val.len - r.end_.val := by + apply List.idrop_len + . scalar_tac + . scalar_tac + let ns := s_beg.append (ss.val.append s_end) + have : ns.len = s.val.len := by simp [*] + ret ⟨ ns, by simp_all [← List.len_eq_length]; scalar_tac ⟩ + else + fail panic + +@[pspec] +theorem Slice.update_subslice_spec {α : Type u} [Inhabited α] (a : Slice α) (r : Range Usize) (ss : Slice α) + (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : ss.length = r.end_.val - r.start.val) : + ∃ na, update_subslice α a r ss = ret na ∧ + (∀ i, 0 ≤ i → i < r.start.val → na.index_s i = a.index_s i) ∧ + (∀ i, r.start.val ≤ i → i < r.end_.val → na.index_s i = ss.index_s (i - r.start.val)) ∧ + (∀ i, r.end_.val ≤ i → i < a.length → na.index_s i = a.index_s i) := by + simp [update_subslice, *] + have h := List.replace_slice_index r.start.val r.end_.val a.val ss.val + (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) + simp [List.replace_slice, *] at h + have ⟨ h0, h1, h2 ⟩ := h + clear h + split_conjs + . intro i _ _ + have := h0 i (by int_tac) (by int_tac) + simp [*] + . intro i _ _ + have := h1 i (by int_tac) (by int_tac) + simp [*] + . intro i _ _ + have := h2 i (by int_tac) (by int_tac) + simp [*] + +/- Trait declaration: [core::slice::index::private_slice_index::Sealed] -/ +structure core.slice.index.private_slice_index.Sealed (Self : Type) where + +/- Trait declaration: [core::slice::index::SliceIndex] -/ +structure core.slice.index.SliceIndex (Self T : Type) where + sealedInst : core.slice.index.private_slice_index.Sealed Self + Output : Type + get : Self → T → Result (Option Output) + get_mut : Self → T → Result (Option Output) + get_mut_back : Self → T → Option Output → Result T + get_unchecked : Self → ConstRawPtr T → Result (ConstRawPtr Output) + get_unchecked_mut : Self → MutRawPtr T → Result (MutRawPtr Output) + index : Self → T → Result Output + index_mut : Self → T → Result Output + index_mut_back : Self → T → Output → Result T + +/- [core::slice::index::[T]::index]: forward function -/ +def core.slice.index.Slice.index + (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) + (slice : Slice T) (i : I) : Result inst.Output := do + let x ← inst.get i slice + match x with + | none => fail panic + | some x => ret x + +/- [core::slice::index::Range:::get]: forward function -/ +def core.slice.index.Range.get (T : Type) (i : Range Usize) (slice : Slice T) : + Result (Option (Slice T)) := + sorry -- TODO + +/- [core::slice::index::Range::get_mut]: forward function -/ +def core.slice.index.Range.get_mut + (T : Type) : Range Usize → Slice T → Result (Option (Slice T)) := + sorry -- TODO + +/- [core::slice::index::Range::get_mut]: backward function 0 -/ +def core.slice.index.Range.get_mut_back + (T : Type) : + Range Usize → Slice T → Option (Slice T) → Result (Slice T) := + sorry -- TODO + +/- [core::slice::index::Range::get_unchecked]: forward function -/ +def core.slice.index.Range.get_unchecked + (T : Type) : + Range Usize → ConstRawPtr (Slice T) → Result (ConstRawPtr (Slice T)) := + -- Don't know what the model should be - for now we always fail to make + -- sure code which uses it fails + fun _ _ => fail panic + +/- [core::slice::index::Range::get_unchecked_mut]: forward function -/ +def core.slice.index.Range.get_unchecked_mut + (T : Type) : + Range Usize → MutRawPtr (Slice T) → Result (MutRawPtr (Slice T)) := + -- Don't know what the model should be - for now we always fail to make + -- sure code which uses it fails + fun _ _ => fail panic + +/- [core::slice::index::Range::index]: forward function -/ +def core.slice.index.Range.index + (T : Type) : Range Usize → Slice T → Result (Slice T) := + sorry -- TODO + +/- [core::slice::index::Range::index_mut]: forward function -/ +def core.slice.index.Range.index_mut + (T : Type) : Range Usize → Slice T → Result (Slice T) := + sorry -- TODO + +/- [core::slice::index::Range::index_mut]: backward function 0 -/ +def core.slice.index.Range.index_mut_back + (T : Type) : Range Usize → Slice T → Slice T → Result (Slice T) := + sorry -- TODO + +/- [core::slice::index::[T]::index_mut]: forward function -/ +def core.slice.index.Slice.index_mut + (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) : + Slice T → I → Result inst.Output := + sorry -- TODO + +/- [core::slice::index::[T]::index_mut]: backward function 0 -/ +def core.slice.index.Slice.index_mut_back + (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) : + Slice T → I → inst.Output → Result (Slice T) := + sorry -- TODO + +/- [core::array::[T; N]::index]: forward function -/ +def core.array.Array.index + (T I : Type) (N : Usize) (inst : core.ops.index.Index (Slice T) I) + (a : Array T N) (i : I) : Result inst.Output := + sorry -- TODO + +/- [core::array::[T; N]::index_mut]: forward function -/ +def core.array.Array.index_mut + (T I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T) I) + (a : Array T N) (i : I) : Result inst.indexInst.Output := + sorry -- TODO + +/- [core::array::[T; N]::index_mut]: backward function 0 -/ +def core.array.Array.index_mut_back + (T I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T) I) + (a : Array T N) (i : I) (x : inst.indexInst.Output) : Result (Array T N) := + sorry -- TODO + +/- Trait implementation: [core::slice::index::[T]] -/ +def core.slice.index.Slice.coreopsindexIndexInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.Index (Slice T) I := { + Output := inst.Output + index := core.slice.index.Slice.index T I inst +} + +/- Trait implementation: [core::slice::index::private_slice_index::Range] -/ +def core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst + : core.slice.index.private_slice_index.Sealed (Range Usize) := {} + +/- Trait implementation: [core::slice::index::Range] -/ +def core.slice.index.Range.coresliceindexSliceIndexInst (T : Type) : + core.slice.index.SliceIndex (Range Usize) (Slice T) := { + sealedInst := + core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst + Output := Slice T + get := core.slice.index.Range.get T + get_mut := core.slice.index.Range.get_mut T + get_mut_back := core.slice.index.Range.get_mut_back T + get_unchecked := core.slice.index.Range.get_unchecked T + get_unchecked_mut := core.slice.index.Range.get_unchecked_mut T + index := core.slice.index.Range.index T + index_mut := core.slice.index.Range.index_mut T + index_mut_back := core.slice.index.Range.index_mut_back T +} + +/- Trait implementation: [core::slice::index::[T]] -/ +def core.slice.index.Slice.coreopsindexIndexMutInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.IndexMut (Slice T) I := { + indexInst := core.slice.index.Slice.coreopsindexIndexInst T I inst + index_mut := core.slice.index.Slice.index_mut T I inst + index_mut_back := core.slice.index.Slice.index_mut_back T I inst +} + +/- Trait implementation: [core::array::[T; N]] -/ +def core.array.Array.coreopsindexIndexInst (T I : Type) (N : Usize) + (inst : core.ops.index.Index (Slice T) I) : + core.ops.index.Index (Array T N) I := { + Output := inst.Output + index := core.array.Array.index T I N inst +} + +/- Trait implementation: [core::array::[T; N]] -/ +def core.array.Array.coreopsindexIndexMutInst (T I : Type) (N : Usize) + (inst : core.ops.index.IndexMut (Slice T) I) : + core.ops.index.IndexMut (Array T N) I := { + indexInst := core.array.Array.coreopsindexIndexInst T I N inst.indexInst + index_mut := core.array.Array.index_mut T I N inst + index_mut_back := core.array.Array.index_mut_back T I N inst +} + +/- [core::slice::index::usize::get]: forward function -/ +def core.slice.index.Usize.get + (T : Type) : Usize → Slice T → Result (Option T) := + sorry -- TODO + +/- [core::slice::index::usize::get_mut]: forward function -/ +def core.slice.index.Usize.get_mut + (T : Type) : Usize → Slice T → Result (Option T) := + sorry -- TODO + +/- [core::slice::index::usize::get_mut]: backward function 0 -/ +def core.slice.index.Usize.get_mut_back + (T : Type) : Usize → Slice T → Option T → Result (Slice T) := + sorry -- TODO + +/- [core::slice::index::usize::get_unchecked]: forward function -/ +def core.slice.index.Usize.get_unchecked + (T : Type) : Usize → ConstRawPtr (Slice T) → Result (ConstRawPtr T) := + sorry -- TODO + +/- [core::slice::index::usize::get_unchecked_mut]: forward function -/ +def core.slice.index.Usize.get_unchecked_mut + (T : Type) : Usize → MutRawPtr (Slice T) → Result (MutRawPtr T) := + sorry -- TODO + +/- [core::slice::index::usize::index]: forward function -/ +def core.slice.index.Usize.index (T : Type) : Usize → Slice T → Result T := + sorry -- TODO + +/- [core::slice::index::usize::index_mut]: forward function -/ +def core.slice.index.Usize.index_mut (T : Type) : Usize → Slice T → Result T := + sorry -- TODO + +/- [core::slice::index::usize::index_mut]: backward function 0 -/ +def core.slice.index.Usize.index_mut_back + (T : Type) : Usize → Slice T → T → Result (Slice T) := + sorry -- TODO + +/- Trait implementation: [core::slice::index::private_slice_index::usize] -/ +def core.slice.index.private_slice_index.usize.coresliceindexprivate_slice_indexSealedInst + : core.slice.index.private_slice_index.Sealed Usize := {} + +/- Trait implementation: [core::slice::index::usize] -/ +def core.slice.index.usize.coresliceindexSliceIndexInst (T : Type) : + core.slice.index.SliceIndex Usize (Slice T) := { + sealedInst := core.slice.index.private_slice_index.usize.coresliceindexprivate_slice_indexSealedInst + Output := T + get := core.slice.index.Usize.get T + get_mut := core.slice.index.Usize.get_mut T + get_mut_back := core.slice.index.Usize.get_mut_back T + get_unchecked := core.slice.index.Usize.get_unchecked T + get_unchecked_mut := core.slice.index.Usize.get_unchecked_mut T + index := core.slice.index.Usize.index T + index_mut := core.slice.index.Usize.index_mut T + index_mut_back := core.slice.index.Usize.index_mut_back T +} + +end Primitives diff --git a/backends/lean/Base/Primitives/Base.lean b/backends/lean/Base/Primitives/Base.lean index 7c0fa3bb..7fc33251 100644 --- a/backends/lean/Base/Primitives/Base.lean +++ b/backends/lean/Base/Primitives/Base.lean @@ -120,11 +120,18 @@ def Result.attach {α: Type} (o : Result α): Result { x : α // o = ret x } := -- MISC -- ---------- -@[simp] def mem.replace (a : Type) (x : a) (_ : a) : a := x -@[simp] def mem.replace_back (a : Type) (_ : a) (y : a) : a := y +@[simp] def core.mem.replace (a : Type) (x : a) (_ : a) : a := x +@[simp] def core.mem.replace_back (a : Type) (_ : a) (y : a) : a := y /-- Aeneas-translated function -- useful to reduce non-recursive definitions. Use with `simp [ aeneas ]` -/ register_simp_attr aeneas +-- We don't really use raw pointers for now +structure MutRawPtr (T : Type) where + v : T + +structure ConstRawPtr (T : Type) where + v : T + end Primitives diff --git a/backends/lean/Base/Primitives/CoreOps.lean b/backends/lean/Base/Primitives/CoreOps.lean new file mode 100644 index 00000000..da458f66 --- /dev/null +++ b/backends/lean/Base/Primitives/CoreOps.lean @@ -0,0 +1,37 @@ +import Lean +import Base.Primitives.Base + +open Primitives +open Result + +namespace core.ops + +namespace index -- core.ops.index + +/- Trait declaration: [core::ops::index::Index] -/ +structure Index (Self Idx : Type) where + Output : Type + index : Self → Idx → Result Output + +/- Trait declaration: [core::ops::index::IndexMut] -/ +structure IndexMut (Self Idx : Type) where + indexInst : Index Self Idx + index_mut : Self → Idx → Result indexInst.Output + index_mut_back : Self → Idx → indexInst.Output → Result Self + +end index -- core.ops.index + +namespace deref -- core.ops.deref + +structure Deref (Self : Type) where + Target : Type + deref : Self → Result Target + +structure DerefMut (Self : Type) where + derefInst : Deref Self + deref_mut : Self → Result derefInst.Target + deref_mut_back : Self → derefInst.Target → Result Self + +end deref -- core.ops.deref + +end core.ops diff --git a/backends/lean/Base/Primitives/Range.lean b/backends/lean/Base/Primitives/Range.lean index 26cbee42..a268bcba 100644 --- a/backends/lean/Base/Primitives/Range.lean +++ b/backends/lean/Base/Primitives/Range.lean @@ -11,7 +11,7 @@ import Base.Progress.Base namespace Primitives -structure Range (α : Type u) where +structure core.ops.range.Range (α : Type u) where mk :: start: α end_: α diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean index 55227a9f..ec9665a5 100644 --- a/backends/lean/Base/Primitives/Scalar.lean +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -230,6 +230,20 @@ def Scalar.cMax (ty : ScalarTy) : Int := | .Usize => Scalar.max .U32 | _ => Scalar.max ty +theorem Scalar.min_lt_max (ty : ScalarTy) : Scalar.min ty < Scalar.max ty := by + cases ty <;> simp [Scalar.min, Scalar.max] + . simp [Isize.min, Isize.max] + have h1 := Isize.refined_min.property + have h2 := Isize.refined_max.property + cases h1 <;> cases h2 <;> simp [*] + . simp [Usize.max] + have h := Usize.refined_max.property + cases h <;> simp [*] + +theorem Scalar.min_le_max (ty : ScalarTy) : Scalar.min ty ≤ Scalar.max ty := by + have := Scalar.min_lt_max ty + int_tac + theorem Scalar.cMin_bound ty : Scalar.min ty ≤ Scalar.cMin ty := by cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * have h := Isize.refined_min.property @@ -395,6 +409,34 @@ def Scalar.cast {src_ty : ScalarTy} (tgt_ty : ScalarTy) (x : Scalar src_ty) : Re @[reducible] def U64 := Scalar .U64 @[reducible] def U128 := Scalar .U128 +-- TODO: reducible? +@[reducible] def core_isize_min : Isize := Scalar.ofInt Isize.min (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Isize)) +@[reducible] def core_isize_max : Isize := Scalar.ofInt Isize.max (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Isize)) +@[reducible] def core_i8_min : I8 := Scalar.ofInt I8.min +@[reducible] def core_i8_max : I8 := Scalar.ofInt I8.max +@[reducible] def core_i16_min : I16 := Scalar.ofInt I16.min +@[reducible] def core_i16_max : I16 := Scalar.ofInt I16.max +@[reducible] def core_i32_min : I32 := Scalar.ofInt I32.min +@[reducible] def core_i32_max : I32 := Scalar.ofInt I32.max +@[reducible] def core_i64_min : I64 := Scalar.ofInt I64.min +@[reducible] def core_i64_max : I64 := Scalar.ofInt I64.max +@[reducible] def core_i128_min : I128 := Scalar.ofInt I128.min +@[reducible] def core_i128_max : I128 := Scalar.ofInt I128.max + +-- TODO: reducible? +@[reducible] def core_usize_min : Usize := Scalar.ofInt Usize.min +@[reducible] def core_usize_max : Usize := Scalar.ofInt Usize.max (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Usize)) +@[reducible] def core_u8_min : U8 := Scalar.ofInt U8.min +@[reducible] def core_u8_max : U8 := Scalar.ofInt U8.max +@[reducible] def core_u16_min : U16 := Scalar.ofInt U16.min +@[reducible] def core_u16_max : U16 := Scalar.ofInt U16.max +@[reducible] def core_u32_min : U32 := Scalar.ofInt U32.min +@[reducible] def core_u32_max : U32 := Scalar.ofInt U32.max +@[reducible] def core_u64_min : U64 := Scalar.ofInt U64.min +@[reducible] def core_u64_max : U64 := Scalar.ofInt U64.max +@[reducible] def core_u128_min : U128 := Scalar.ofInt U128.min +@[reducible] def core_u128_max : U128 := Scalar.ofInt U128.max + -- TODO: below: not sure this is the best way. -- Should we rather overload operations like +, -, etc.? -- Also, it is possible to automate the generation of those definitions @@ -861,33 +903,33 @@ theorem Scalar.rem_unsigned_spec {ty} (s: ¬ ty.isSigned) (x : Scalar ty) {y : S -- ofIntCore -- TODO: typeclass? -@[reducible] def Isize.ofIntCore := @Scalar.ofIntCore .Isize -@[reducible] def I8.ofIntCore := @Scalar.ofIntCore .I8 -@[reducible] def I16.ofIntCore := @Scalar.ofIntCore .I16 -@[reducible] def I32.ofIntCore := @Scalar.ofIntCore .I32 -@[reducible] def I64.ofIntCore := @Scalar.ofIntCore .I64 -@[reducible] def I128.ofIntCore := @Scalar.ofIntCore .I128 -@[reducible] def Usize.ofIntCore := @Scalar.ofIntCore .Usize -@[reducible] def U8.ofIntCore := @Scalar.ofIntCore .U8 -@[reducible] def U16.ofIntCore := @Scalar.ofIntCore .U16 -@[reducible] def U32.ofIntCore := @Scalar.ofIntCore .U32 -@[reducible] def U64.ofIntCore := @Scalar.ofIntCore .U64 -@[reducible] def U128.ofIntCore := @Scalar.ofIntCore .U128 +def Isize.ofIntCore := @Scalar.ofIntCore .Isize +def I8.ofIntCore := @Scalar.ofIntCore .I8 +def I16.ofIntCore := @Scalar.ofIntCore .I16 +def I32.ofIntCore := @Scalar.ofIntCore .I32 +def I64.ofIntCore := @Scalar.ofIntCore .I64 +def I128.ofIntCore := @Scalar.ofIntCore .I128 +def Usize.ofIntCore := @Scalar.ofIntCore .Usize +def U8.ofIntCore := @Scalar.ofIntCore .U8 +def U16.ofIntCore := @Scalar.ofIntCore .U16 +def U32.ofIntCore := @Scalar.ofIntCore .U32 +def U64.ofIntCore := @Scalar.ofIntCore .U64 +def U128.ofIntCore := @Scalar.ofIntCore .U128 -- ofInt -- TODO: typeclass? -@[reducible] def Isize.ofInt := @Scalar.ofInt .Isize -@[reducible] def I8.ofInt := @Scalar.ofInt .I8 -@[reducible] def I16.ofInt := @Scalar.ofInt .I16 -@[reducible] def I32.ofInt := @Scalar.ofInt .I32 -@[reducible] def I64.ofInt := @Scalar.ofInt .I64 -@[reducible] def I128.ofInt := @Scalar.ofInt .I128 -@[reducible] def Usize.ofInt := @Scalar.ofInt .Usize -@[reducible] def U8.ofInt := @Scalar.ofInt .U8 -@[reducible] def U16.ofInt := @Scalar.ofInt .U16 -@[reducible] def U32.ofInt := @Scalar.ofInt .U32 -@[reducible] def U64.ofInt := @Scalar.ofInt .U64 -@[reducible] def U128.ofInt := @Scalar.ofInt .U128 +abbrev Isize.ofInt := @Scalar.ofInt .Isize +abbrev I8.ofInt := @Scalar.ofInt .I8 +abbrev I16.ofInt := @Scalar.ofInt .I16 +abbrev I32.ofInt := @Scalar.ofInt .I32 +abbrev I64.ofInt := @Scalar.ofInt .I64 +abbrev I128.ofInt := @Scalar.ofInt .I128 +abbrev Usize.ofInt := @Scalar.ofInt .Usize +abbrev U8.ofInt := @Scalar.ofInt .U8 +abbrev U16.ofInt := @Scalar.ofInt .U16 +abbrev U32.ofInt := @Scalar.ofInt .U32 +abbrev U64.ofInt := @Scalar.ofInt .U64 +abbrev U128.ofInt := @Scalar.ofInt .U128 postfix:max "#isize" => Isize.ofInt postfix:max "#i8" => I8.ofInt @@ -905,9 +947,46 @@ postfix:max "#u128" => U128.ofInt -- Testing the notations example : Result Usize := 0#usize + 1#usize +-- TODO: factor those lemmas out @[simp] theorem Scalar.ofInt_val_eq {ty} (h : Scalar.min ty ≤ x ∧ x ≤ Scalar.max ty) : (Scalar.ofInt x h).val = x := by simp [Scalar.ofInt, Scalar.ofIntCore] +@[simp] theorem Isize.ofInt_val_eq (h : Scalar.min ScalarTy.Isize ≤ x ∧ x ≤ Scalar.max ScalarTy.Isize) : (Isize.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem I8.ofInt_val_eq (h : Scalar.min ScalarTy.I8 ≤ x ∧ x ≤ Scalar.max ScalarTy.I8) : (I8.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem I16.ofInt_val_eq (h : Scalar.min ScalarTy.I16 ≤ x ∧ x ≤ Scalar.max ScalarTy.I16) : (I16.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem I32.ofInt_val_eq (h : Scalar.min ScalarTy.I32 ≤ x ∧ x ≤ Scalar.max ScalarTy.I32) : (I32.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem I64.ofInt_val_eq (h : Scalar.min ScalarTy.I64 ≤ x ∧ x ≤ Scalar.max ScalarTy.I64) : (I64.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem I128.ofInt_val_eq (h : Scalar.min ScalarTy.I128 ≤ x ∧ x ≤ Scalar.max ScalarTy.I128) : (I128.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem Usize.ofInt_val_eq (h : Scalar.min ScalarTy.Usize ≤ x ∧ x ≤ Scalar.max ScalarTy.Usize) : (Usize.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem U8.ofInt_val_eq (h : Scalar.min ScalarTy.U8 ≤ x ∧ x ≤ Scalar.max ScalarTy.U8) : (U8.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem U16.ofInt_val_eq (h : Scalar.min ScalarTy.U16 ≤ x ∧ x ≤ Scalar.max ScalarTy.U16) : (U16.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem U32.ofInt_val_eq (h : Scalar.min ScalarTy.U32 ≤ x ∧ x ≤ Scalar.max ScalarTy.U32) : (U32.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem U64.ofInt_val_eq (h : Scalar.min ScalarTy.U64 ≤ x ∧ x ≤ Scalar.max ScalarTy.U64) : (U64.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + +@[simp] theorem U128.ofInt_val_eq (h : Scalar.min ScalarTy.U128 ≤ x ∧ x ≤ Scalar.max ScalarTy.U128) : (U128.ofInt x h).val = x := by + apply Scalar.ofInt_val_eq h + -- Comparisons instance {ty} : LT (Scalar ty) where lt a b := LT.lt a.val b.val diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index c4c4d9f2..bbed6082 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -6,7 +6,7 @@ import Mathlib.Tactic.RunCmd import Mathlib.Tactic.Linarith import Base.IList import Base.Primitives.Scalar -import Base.Primitives.Array +import Base.Primitives.ArraySlice import Base.Arith import Base.Progress.Base @@ -14,6 +14,8 @@ namespace Primitives open Result Error +namespace alloc.vec + def Vec (α : Type u) := { l : List α // l.length ≤ Usize.max } instance (a : Type u) : Arith.HasIntProp (Vec a) where @@ -79,7 +81,7 @@ theorem Vec.insert_spec {α : Type u} (v: Vec α) (i: Usize) (x: α) ∃ nv, v.insert α i x = ret nv ∧ nv.val = v.val.update i.val x := by simp [insert, *] -def Vec.index_shared (α : Type u) (v: Vec α) (i: Usize) : Result α := +def Vec.index_usize {α : Type u} (v: Vec α) (i: Usize) : Result α := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some x => ret x @@ -90,51 +92,83 @@ def Vec.index_shared (α : Type u) (v: Vec α) (i: Usize) : Result α := -/ @[pspec] -theorem Vec.index_shared_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_shared α i = ret x ∧ x = v.val.index i.val := by - simp only [index_shared] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - --- This shouldn't be used -def Vec.index_back (α : Type u) (v: Vec α) (i: Usize) (_: α) : Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - -def Vec.index_mut (α : Type u) (v: Vec α) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -@[pspec] -theorem Vec.index_mut_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) +theorem Vec.index_usize_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) (hbound : i.val < v.length) : - ∃ x, v.index_mut α i = ret x ∧ x = v.val.index i.val := by - simp only [index_mut] + ∃ x, v.index_usize i = ret x ∧ x = v.val.index i.val := by + simp only [index_usize] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) simp [*] -def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := +def Vec.update_usize {α : Type u} (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some _ => .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ @[pspec] -theorem Vec.index_mut_back_spec {α : Type u} (v: Vec α) (i: Usize) (x : α) +theorem Vec.update_usize_spec {α : Type u} (v: Vec α) (i: Usize) (x : α) (hbound : i.val < v.length) : - ∃ nv, v.index_mut_back α i x = ret nv ∧ + ∃ nv, v.update_usize i x = ret nv ∧ nv.val = v.val.update i.val x := by - simp only [index_mut_back] + simp only [update_usize] have h := List.indexOpt_bounds v.val i.val split . simp_all [length]; cases h <;> scalar_tac . simp_all +/- [alloc::vec::Vec::index]: forward function -/ +def Vec.index (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) + (self : Vec T) (i : I) : Result inst.Output := + sorry -- TODO + +/- [alloc::vec::Vec::index_mut]: forward function -/ +def Vec.index_mut (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) + (self : Vec T) (i : I) : Result inst.Output := + sorry -- TODO + +/- [alloc::vec::Vec::index_mut]: backward function 0 -/ +def Vec.index_mut_back + (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) + (self : Vec T) (i : I) (x : inst.Output) : Result (alloc.vec.Vec T) := + sorry -- TODO + +/- Trait implementation: [alloc::vec::Vec] -/ +def Vec.coreopsindexIndexInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.Index (alloc.vec.Vec T) I := { + Output := inst.Output + index := Vec.index T I inst +} + +/- Trait implementation: [alloc::vec::Vec] -/ +def Vec.coreopsindexIndexMutInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.IndexMut (alloc.vec.Vec T) I := { + indexInst := Vec.coreopsindexIndexInst T I inst + index_mut := Vec.index_mut T I inst + index_mut_back := Vec.index_mut_back T I inst +} + +@[simp] +theorem Vec.index_slice_index {α : Type} (v : Vec α) (i : Usize) : + Vec.index α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i = + Vec.index_usize v i := + sorry + +@[simp] +theorem Vec.index_mut_slice_index {α : Type} (v : Vec α) (i : Usize) : + Vec.index_mut α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i = + Vec.index_usize v i := + sorry + +@[simp] +theorem Vec.index_mut_back_slice_index {α : Type} (v : Vec α) (i : Usize) (x : α) : + Vec.index_mut_back α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i x = + Vec.update_usize v i x := + sorry + +end alloc.vec + end Primitives diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 8b0759c5..ba63f09d 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -8,6 +8,27 @@ namespace Progress open Lean Elab Term Meta Tactic open Utils +-- TODO: the scalar types annoyingly often get reduced when we use the progress +-- tactic. We should find a way of controling reduction. For now we use rewriting +-- lemmas to make sure the goal remains clean, but this complexifies proof terms. +-- It seems there used to be a `fold` tactic. +theorem scalar_isize_eq : Primitives.Scalar .Isize = Primitives.Isize := by rfl +theorem scalar_i8_eq : Primitives.Scalar .I8 = Primitives.I8 := by rfl +theorem scalar_i16_eq : Primitives.Scalar .I16 = Primitives.I16 := by rfl +theorem scalar_i32_eq : Primitives.Scalar .I32 = Primitives.I32 := by rfl +theorem scalar_i64_eq : Primitives.Scalar .I64 = Primitives.I64 := by rfl +theorem scalar_i128_eq : Primitives.Scalar .I128 = Primitives.I128 := by rfl +theorem scalar_usize_eq : Primitives.Scalar .Usize = Primitives.Usize := by rfl +theorem scalar_u8_eq : Primitives.Scalar .U8 = Primitives.U8 := by rfl +theorem scalar_u16_eq : Primitives.Scalar .U16 = Primitives.U16 := by rfl +theorem scalar_u32_eq : Primitives.Scalar .U32 = Primitives.U32 := by rfl +theorem scalar_u64_eq : Primitives.Scalar .U64 = Primitives.U64 := by rfl +theorem scalar_u128_eq : Primitives.Scalar .U128 = Primitives.U128 := by rfl +def scalar_eqs := [ + ``scalar_isize_eq, ``scalar_i8_eq, ``scalar_i16_eq, ``scalar_i32_eq, ``scalar_i64_eq, ``scalar_i128_eq, + ``scalar_usize_eq, ``scalar_u8_eq, ``scalar_u16_eq, ``scalar_u32_eq, ``scalar_u64_eq, ``scalar_u128_eq +] + inductive TheoremOrLocal where | Theorem (thName : Name) | Local (asm : LocalDecl) @@ -111,8 +132,11 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) splitEqAndPost fun hEq hPost ids => do trace[Progress] "eq and post:\n{hEq} : {← inferType hEq}\n{hPost}" tryTac ( - simpAt [] [``Primitives.bind_tc_ret, ``Primitives.bind_tc_fail, ``Primitives.bind_tc_div] + simpAt true [] + [``Primitives.bind_tc_ret, ``Primitives.bind_tc_fail, ``Primitives.bind_tc_div] [hEq.fvarId!] (.targets #[] true)) + -- TODO: remove this (some types get unfolded too much: we "fold" them back) + tryTac (simpAt true [] scalar_eqs [] .wildcard_dep) -- Clear the equality, unless the user requests not to do so let mgoal ← do if keep.isSome then getMainGoal @@ -359,6 +383,7 @@ namespace Test -- #eval showStoredPSpec -- #eval showStoredPSpecClass -- #eval showStoredPSpecExprClass + open alloc.vec example {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) @@ -384,7 +409,7 @@ namespace Test `α : Type u` where u is quantified, while here we use `α : Type 0` -/ example {α : Type} (v: Vec α) (i: Usize) (x : α) (hbounds : i.val < v.length) : - ∃ nv, v.index_mut_back α i x = ret nv ∧ + ∃ nv, v.update_usize i x = ret nv ∧ nv.val = v.val.update i.val x := by progress simp [*] diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 5224e1c3..b917a789 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -604,16 +604,12 @@ example (h : ∃ x y z, x + y + z ≥ 0) : ∃ x, x ≥ 0 := by rename_i x y z exists x + y + z -/- Call the simp tactic. - The initialization of the context is adapted from Tactic.elabSimpArgs. - Something very annoying is that there is no function which allows to - initialize a simp context without doing an elaboration - as a consequence - we write our own here. -/ -def simpAt (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) - (loc : Tactic.Location) : - Tactic.TacticM Unit := do - -- Initialize with the builtin simp theorems - let simpThms ← Tactic.simpOnlyBuiltins.foldlM (·.addConst ·) ({} : SimpTheorems) +def mkSimpCtx (simpOnly : Bool) (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) : + Tactic.TacticM Simp.Context := do + -- Initialize either with the builtin simp theorems or with all the simp theorems + let simpThms ← + if simpOnly then Tactic.simpOnlyBuiltins.foldlM (·.addConst ·) ({} : SimpTheorems) + else getSimpTheorems -- Add the equational theorem for the declarations to unfold let simpThms ← declsToUnfold.foldlM (fun thms decl => thms.addDeclToUnfold decl) simpThms @@ -637,8 +633,63 @@ def simpAt (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVar throwError "Not a proposition: {thmName}" ) simpThms let congrTheorems ← getSimpCongrTheorems - let ctx : Simp.Context := { simpTheorems := #[simpThms], congrTheorems } + pure { simpTheorems := #[simpThms], congrTheorems } + + +inductive Location where + /-- Apply the tactic everywhere. Same as `Tactic.Location.wildcard` -/ + | wildcard + /-- Apply the tactic everywhere, including in the variable types (i.e., in + assumptions which are not propositions). --/ + | wildcard_dep + /-- Same as Tactic.Location -/ + | targets (hypotheses : Array Syntax) (type : Bool) + +-- Comes from Tactic.simpLocation +def customSimpLocation (ctx : Simp.Context) (discharge? : Option Simp.Discharge := none) + (loc : Location) : TacticM Simp.UsedSimps := do + match loc with + | Location.targets hyps simplifyTarget => + withMainContext do + let fvarIds ← Lean.Elab.Tactic.getFVarIds hyps + go fvarIds simplifyTarget + | Location.wildcard => + withMainContext do + go (← (← getMainGoal).getNondepPropHyps) (simplifyTarget := true) + | Location.wildcard_dep => + withMainContext do + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getDecls + let tgts := (decls.map (fun d => d.fvarId)).toArray + go tgts (simplifyTarget := true) +where + go (fvarIdsToSimp : Array FVarId) (simplifyTarget : Bool) : TacticM Simp.UsedSimps := do + let mvarId ← getMainGoal + let (result?, usedSimps) ← simpGoal mvarId ctx (simplifyTarget := simplifyTarget) (discharge? := discharge?) (fvarIdsToSimp := fvarIdsToSimp) + match result? with + | none => replaceMainGoal [] + | some (_, mvarId) => replaceMainGoal [mvarId] + return usedSimps + +/- Call the simp tactic. + The initialization of the context is adapted from Tactic.elabSimpArgs. + Something very annoying is that there is no function which allows to + initialize a simp context without doing an elaboration - as a consequence + we write our own here. -/ +def simpAt (simpOnly : Bool) (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) + (loc : Location) : + Tactic.TacticM Unit := do + -- Initialize the simp context + let ctx ← mkSimpCtx simpOnly declsToUnfold thms hypsToUse + -- Apply the simplifier + let _ ← customSimpLocation ctx (discharge? := .none) loc + +-- Call the simpAll tactic +def simpAll (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) : + Tactic.TacticM Unit := do + -- Initialize the simp context + let ctx ← mkSimpCtx false declsToUnfold thms hypsToUse -- Apply the simplifier - let _ ← Tactic.simpLocation ctx (discharge? := .none) loc + let _ ← Lean.Meta.simpAll (← getMainGoal) ctx end Utils diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml new file mode 100644 index 00000000..581e218c --- /dev/null +++ b/compiler/AssociatedTypes.ml @@ -0,0 +1,681 @@ +(** This file implements utilities to handle trait associated types, in + particular with normalization helpers. + + When normalizing a type, we simplify the references to the trait associated + types, and choose a representative when there are equalities between types + enforced by local clauses (i.e., clauses of the shape [where Trait1::T = Trait2::U]). + *) + +module T = Types +module TU = TypesUtils +module V = Values +module E = Expressions +module A = LlbcAst +module C = Contexts +module Subst = Substitute +module L = Logging +module UF = UnionFind +module PA = Print.EvalCtxLlbcAst + +(** The local logger *) +let log = L.associated_types_log + +let trait_type_ref_substitute (subst : ('r, 'r1) Subst.subst) + (r : 'r C.trait_type_ref) : 'r1 C.trait_type_ref = + let { C.trait_ref; type_name } = r in + let trait_ref = Subst.trait_ref_substitute subst trait_ref in + { C.trait_ref; type_name } + +(* TODO: how not to duplicate below? *) +module RTyOrd = struct + type t = T.rty + + let compare = T.compare_rty + let to_string = T.show_rty + let pp_t = T.pp_rty + let show_t = T.show_rty +end + +module STyOrd = struct + type t = T.sty + + let compare = T.compare_sty + let to_string = T.show_sty + let pp_t = T.pp_sty + let show_t = T.show_sty +end + +module RTyMap = Collections.MakeMap (RTyOrd) +module STyMap = Collections.MakeMap (STyOrd) + +(* TODO: is it possible not to have this? *) +module type TypeWrapper = sig + type t +end + +(* TODO: don't manage to get the syntax right so using a functor *) +module MakeNormalizer + (R : TypeWrapper) + (RTyMap : Collections.Map with type key = R.t T.region T.ty) + (M : Collections.Map with type key = R.t T.region C.trait_type_ref) = +struct + let compute_norm_trait_types_from_preds + (trait_type_constraints : R.t T.region T.trait_type_constraint list) : + R.t T.region T.ty M.t = + (* Compute a union-find structure by recursively exploring the predicates and clauses *) + let norm : R.t T.region T.ty UF.elem RTyMap.t ref = ref RTyMap.empty in + let get_ref (ty : R.t T.region T.ty) : R.t T.region T.ty UF.elem = + match RTyMap.find_opt ty !norm with + | Some r -> r + | None -> + let r = UF.make ty in + norm := RTyMap.add ty r !norm; + r + in + let add_trait_type_constraint (c : R.t T.region T.trait_type_constraint) = + let trait_ty = T.TraitType (c.trait_ref, c.generics, c.type_name) in + let trait_ty_ref = get_ref trait_ty in + let ty_ref = get_ref c.ty in + let new_repr = UF.get ty_ref in + let merged = UF.union trait_ty_ref ty_ref in + (* Not sure the set operation is necessary, but I want to control which + representative is chosen *) + UF.set merged new_repr + in + (* Explore the local predicates *) + List.iter add_trait_type_constraint trait_type_constraints; + (* TODO: explore the local clauses *) + (* Compute the norm maps *) + let rbindings = + List.map (fun (k, v) -> (k, UF.get v)) (RTyMap.bindings !norm) + in + (* Filter the keys to keep only the trait type aliases *) + let rbindings = + List.filter_map + (fun (k, v) -> + match k with + | T.TraitType (trait_ref, generics, type_name) -> + assert (generics = TypesUtils.mk_empty_generic_args); + Some ({ C.trait_ref; type_name }, v) + | _ -> None) + rbindings + in + M.of_list rbindings +end + +(** Compute the representative classes of trait associated types, for normalization *) +let compute_norm_trait_stypes_from_preds + (trait_type_constraints : T.strait_type_constraint list) : + T.sty C.STraitTypeRefMap.t = + (* Compute the normalization map for the types with regions *) + let module R = struct + type t = T.region_var_id + end in + let module M = C.STraitTypeRefMap in + let module Norm = MakeNormalizer (R) (STyMap) (M) in + Norm.compute_norm_trait_types_from_preds trait_type_constraints + +(** Compute the representative classes of trait associated types, for normalization *) +let compute_norm_trait_types_from_preds + (trait_type_constraints : T.rtrait_type_constraint list) : + T.ety C.ETraitTypeRefMap.t * T.rty C.RTraitTypeRefMap.t = + (* Compute the normalization map for the types with regions *) + let module R = struct + type t = T.region_id + end in + let module M = C.RTraitTypeRefMap in + let module Norm = MakeNormalizer (R) (RTyMap) (M) in + let rbindings = + Norm.compute_norm_trait_types_from_preds trait_type_constraints + in + (* Compute the normalization map for the types with erased regions *) + let ebindings = + List.map + (fun (k, v) -> + ( trait_type_ref_substitute Subst.erase_regions_subst k, + Subst.erase_regions v )) + (M.bindings rbindings) + in + (C.ETraitTypeRefMap.of_list ebindings, rbindings) + +let ctx_add_norm_trait_stypes_from_preds (ctx : C.eval_ctx) + (trait_type_constraints : T.strait_type_constraint list) : C.eval_ctx = + let norm_trait_stypes = + compute_norm_trait_stypes_from_preds trait_type_constraints + in + { ctx with C.norm_trait_stypes } + +let ctx_add_norm_trait_types_from_preds (ctx : C.eval_ctx) + (trait_type_constraints : T.rtrait_type_constraint list) : C.eval_ctx = + let norm_trait_etypes, norm_trait_rtypes = + compute_norm_trait_types_from_preds trait_type_constraints + in + { ctx with C.norm_trait_etypes; norm_trait_rtypes } + +(** A trait instance id refers to a local clause if it only uses the variants: + [Self], [Clause], [ParentClause], [ItemClause] *) +let rec trait_instance_id_is_local_clause (id : 'r T.trait_instance_id) : bool = + match id with + | T.Self | Clause _ -> true + | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ | FnPointer _ -> + false + | ParentClause (id, _, _) | ItemClause (id, _, _, _) -> + trait_instance_id_is_local_clause id + +(** About the conversion functions: for now we need them (TODO: merge ety, rty, etc.), + but they should be applied to types without regions. + *) +type 'r norm_ctx = { + ctx : C.eval_ctx; + get_ty_repr : 'r C.trait_type_ref -> 'r T.ty option; + convert_ety : T.ety -> 'r T.ty; (* TODO: remove? *) + convert_etrait_ref : T.etrait_ref -> 'r T.trait_ref; (* TODO: remove? *) + ty_to_string : 'r T.ty -> string; + generic_params_to_string : T.generic_params -> string; + generic_args_to_string : 'r T.generic_args -> string; + trait_ref_to_string : 'r T.trait_ref -> string; + trait_instance_id_to_string : 'r T.trait_instance_id -> string; + pp_r : Format.formatter -> 'r -> unit; +} + +(** Small utility to lookup trait impls, together with a substitution. + + Remark: one reason we have those small helpers is that all functions are + parameterized by a type variable 'r. The OCaml type inferencer and type + checker are however not very good at generating precise error messages in + this context: if in the body of the function we have an overly constrained + usage of 'r (for instance, the type inferencer deduces 'r should be + [T.erased_region]), it will not be able to pinpoint the location which + introduced the constraints and we just get a type-checking error for the + whole function. The fact that we have mutually recursive functions makes it + worse (the type-checker sometimes indicates a well-typed function as not + well-typed, because it calls a not well-typed function...). + By isolating the places where such errors typically happen in small helpers + (i.e., the places where we convert between different types of regions by + performing substitutions), we make maintenance a lot easier. + *) +let ctx_lookup_trait_impl : + 'r. + 'r norm_ctx -> + T.TraitImplId.id -> + 'r T.generic_args -> + A.trait_impl * (T.region_var_id T.region, 'r) Subst.subst = + fun ctx impl_id generics -> + (* Lookup the implementation *) + let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in + (* The substitution *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = + Subst.make_subst_from_generics_no_regions trait_impl.generics generics + tr_self + in + (* Return *) + (trait_impl, subst) + +let ctx_lookup_trait_impl_ty : + 'r. + 'r norm_ctx -> T.TraitImplId.id -> 'r T.generic_args -> string -> 'r T.ty + = + fun ctx impl_id generics type_name -> + (* Lookup the implementation *) + let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + (* Lookup the type *) + let ty = snd (List.assoc type_name trait_impl.types) in + (* Annoying: convert etype to an stype - TODO: how to avoid that? *) + let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in + (* Substitute *) + Subst.ty_substitute subst ty + +let ctx_lookup_trait_impl_parent_clause : + 'r. + 'r norm_ctx -> + T.TraitImplId.id -> + 'r T.generic_args -> + T.TraitClauseId.id -> + 'r T.trait_ref = + fun ctx impl_id generics clause_id -> + (* Lookup the implementation *) + let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + (* Lookup the clause *) + let clause = T.TraitClauseId.nth trait_impl.parent_trait_refs clause_id in + (* Sanity check: the clause necessarily refers to an impl *) + let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in + (* Substitute *) + Subst.trait_ref_substitute subst clause + +let ctx_lookup_trait_impl_item_clause : + 'r. + 'r norm_ctx -> + T.TraitImplId.id -> + 'r T.generic_args -> + string -> + T.TraitClauseId.id -> + 'r T.trait_ref = + fun ctx impl_id generics item_name clause_id -> + (* Lookup the implementation *) + let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + (* Lookup the item then its clause *) + let item = List.assoc item_name trait_impl.types in + let clause = T.TraitClauseId.nth (fst item) clause_id in + (* Sanity check: the clause necessarily refers to an impl *) + let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in + (* Annoying: convert etype to an stype - TODO: how to avoid that? *) + let clause : T.strait_ref = + TypesUtils.etrait_ref_no_regions_to_gr_trait_ref clause + in + (* Substitute *) + Subst.trait_ref_substitute subst clause + +(** Normalize a type by simplifying the references to trait associated types + and choosing a representative when there are equalities between types + enforced by local clauses (i.e., `where Trait1::T = Trait2::U`. + + See the comments for {!ctx_normalize_trait_instance_id}. + *) +let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = + fun ctx ty -> + log#ldebug (lazy ("ctx_normalize_ty: " ^ ctx.ty_to_string ty)); + match ty with + | T.Adt (id, generics) -> Adt (id, ctx_normalize_generic_args ctx generics) + | TypeVar _ | Literal _ | Never -> ty + | Ref (r, ty, rkind) -> + let ty = ctx_normalize_ty ctx ty in + T.Ref (r, ty, rkind) + | RawPtr (ty, rkind) -> + let ty = ctx_normalize_ty ctx ty in + RawPtr (ty, rkind) + | Arrow (inputs, output) -> + let inputs = List.map (ctx_normalize_ty ctx) inputs in + let output = ctx_normalize_ty ctx output in + Arrow (inputs, output) + | TraitType (trait_ref, generics, type_name) -> ( + log#ldebug + (lazy + ("ctx_normalize_ty:\n- trait type: " ^ ctx.ty_to_string ty + ^ "\n- trait_ref: " + ^ ctx.trait_ref_to_string trait_ref + ^ "\n- raw trait ref:\n" + ^ T.show_trait_ref ctx.pp_r trait_ref + ^ "\n- generics:\n" + ^ ctx.generic_args_to_string generics)); + (* Normalize and attempt to project the type from the trait ref *) + let trait_ref = ctx_normalize_trait_ref ctx trait_ref in + let generics = ctx_normalize_generic_args ctx generics in + (* For now, we don't support higher order types *) + assert (generics = TypesUtils.mk_empty_generic_args); + let ty : 'r T.ty = + match trait_ref.trait_id with + | T.TraitRef + { T.trait_id = T.TraitImpl impl_id; generics = ref_generics; _ } -> + assert (ref_generics = TypesUtils.mk_empty_generic_args); + log#ldebug + (lazy + ("ctx_normalize_ty: trait type: trait ref: " + ^ ctx.ty_to_string ty)); + (* Lookup the type *) + let ty = + ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics type_name + in + (* Normalize *) + ctx_normalize_ty ctx ty + | T.TraitImpl impl_id -> + log#ldebug + (lazy + ("ctx_normalize_ty (trait impl):\n- trait type: " + ^ ctx.ty_to_string ty ^ "\n- trait_ref: " + ^ ctx.trait_ref_to_string trait_ref + ^ "\n- raw trait ref:\n" + ^ T.show_trait_ref ctx.pp_r trait_ref)); + (* This happens. This doesn't come from the substitutions + performed by Aeneas (the [TraitImpl] would be wrapped in a + [TraitRef] but from non-normalized traits translated from + the Rustc AST. + TODO: factor out with the branch above. + *) + (* Lookup the type *) + let ty = + ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics type_name + in + (* Normalize *) + ctx_normalize_ty ctx ty + | _ -> + log#ldebug + (lazy + ("ctx_normalize_ty: trait type: not a trait ref: " + ^ ctx.ty_to_string ty ^ "\n- trait_ref: " + ^ ctx.trait_ref_to_string trait_ref + ^ "\n- raw trait ref:\n" + ^ T.show_trait_ref ctx.pp_r trait_ref)); + (* We can't project *) + assert (trait_instance_id_is_local_clause trait_ref.trait_id); + T.TraitType (trait_ref, generics, type_name) + in + let tr : 'r C.trait_type_ref = { C.trait_ref; type_name } in + (* Lookup the representative, if there is *) + match ctx.get_ty_repr tr with None -> ty | Some ty -> ty) + +(** This returns the normalized trait instance id together with an optional + reference to a trait **implementation** (the `trait_ref` we return has + necessarily for instance id a [TraitImpl]). + + We need this in particular to simplify the trait instance ids after we + performed a substitution. + + Example: + ======== + {[ + trait Trait { + type S + } + + impl TraitImpl for Foo { + type S = usize + } + + fn f<T : Trait>(...) -> T::S; + + ... + let x = f<Foo>[TraitImpl](...); + (* The return type of the call to f is: + T::S ~~> TraitImpl::S ~~> usize + *) + ]} + + Several remarks: + - as we do not allow higher-order types (yet) then local clauses (and + sub-clauses) can't have generic arguments + - the [TraitRef] case only happens because of substitution, the role of + the normalization is in particular to eliminate it. Inside a [TraitRef] + there is necessarily: + - an id referencing a local (sub-)clause, that is an id using the variants + [Self], [Clause], [ItemClause] and [ParentClause] exclusively. We can't + simplify those cases: all we can do is remove the [TraitRef] wrapper + by leveraging the fact that the generic arguments must be empty. + - a [TraitImpl]. Note that the [TraitImpl] is necessarily just a [TraitImpl], + it can't be for instance a [ParentClause(TraitImpl ...)] because the + trait resolution would then directly reference the implementation + designated by [ParentClause(TraitImpl ...)] (and same for the other cases). + In this case we can lookup the trait implementation and recursively project + over it. + *) +and ctx_normalize_trait_instance_id : + 'r. + 'r norm_ctx -> + 'r T.trait_instance_id -> + 'r T.trait_instance_id * 'r T.trait_ref option = + fun ctx id -> + match id with + | Self -> (id, None) + | TraitImpl _ -> + (* The [TraitImpl] shouldn't be inside any projection - we check this + elsewhere by asserting that whenever we return [None] for the impl + trait ref, then the id actually refers to a local clause. *) + (id, None) + | Clause _ -> (id, None) + | BuiltinOrAuto _ -> (id, None) + | ParentClause (inst_id, decl_id, clause_id) -> ( + let inst_id, impl = ctx_normalize_trait_instance_id ctx inst_id in + (* Check if the inst_id refers to a specific implementation, if yes project *) + match impl with + | None -> + (* This is actually a local clause *) + assert (trait_instance_id_is_local_clause inst_id); + (ParentClause (inst_id, decl_id, clause_id), None) + | Some impl -> + (* We figure out the parent clause by doing the following: + {[ + // The implementation we are looking at + impl Impl1 : Trait1 { ... } + + // Check the trait it implements + trait Trait1 : ParentTrait1 + ParentTrait2 { ... } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + those are the parent clauses + ]} + *) + (* Lookup the clause *) + let impl_id = + TypesUtils.trait_instance_id_as_trait_impl impl.trait_id + in + let clause = + ctx_lookup_trait_impl_parent_clause ctx impl_id impl.generics + clause_id + in + (* Normalize the clause *) + let clause = ctx_normalize_trait_ref ctx clause in + (TraitRef clause, Some clause)) + | ItemClause (inst_id, decl_id, item_name, clause_id) -> ( + let inst_id, impl = ctx_normalize_trait_instance_id ctx inst_id in + (* Check if the inst_id refers to a specific implementation, if yes project *) + match impl with + | None -> + (* This is actually a local clause *) + assert (trait_instance_id_is_local_clause inst_id); + (ItemClause (inst_id, decl_id, item_name, clause_id), None) + | Some impl -> + (* We figure out the item clause by doing the following: + {[ + // The implementation we are looking at + impl Impl1 : Trait1<R> { + type S = ... + with Impl2 : Trait2 ... // Instances satisfying the declared bounds + ^^^^^^^^^^^^^^^^^^ + Lookup the clause from here + } + ]} + *) + (* Lookup the impl *) + let impl_id = + TypesUtils.trait_instance_id_as_trait_impl impl.trait_id + in + let clause = + ctx_lookup_trait_impl_item_clause ctx impl_id impl.generics + item_name clause_id + in + (* Normalize the clause *) + let clause = ctx_normalize_trait_ref ctx clause in + (TraitRef clause, Some clause)) + | TraitRef { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } -> + (* We can't simplify the id *yet* : we will simplify it when projecting. + However, we have an implementation to return *) + (* Normalize the generics *) + let generics = ctx_normalize_generic_args ctx generics in + let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in + let trait_ref : 'r T.trait_ref = + { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } + in + (TraitRef trait_ref, Some trait_ref) + | TraitRef trait_ref -> + (* The trait instance id necessarily refers to a local sub-clause. We + can't project over it and can only peel off the [TraitRef] wrapper *) + assert (trait_instance_id_is_local_clause trait_ref.trait_id); + assert (trait_ref.generics = TypesUtils.mk_empty_generic_args); + (trait_ref.trait_id, None) + | FnPointer ty -> + let ty = ctx_normalize_ty ctx ty in + (* TODO: we might want to return the ref to the function pointer, + in order to later normalize a call to this function pointer *) + (FnPointer ty, None) + | UnknownTrait _ -> + (* This is actually an error case *) + (id, None) + +and ctx_normalize_generic_args (ctx : 'r norm_ctx) + (generics : 'r T.generic_args) : 'r T.generic_args = + let { T.regions; types; const_generics; trait_refs } = generics in + let types = List.map (ctx_normalize_ty ctx) types in + let trait_refs = List.map (ctx_normalize_trait_ref ctx) trait_refs in + { T.regions; types; const_generics; trait_refs } + +and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : + 'r T.trait_ref = + log#ldebug + (lazy + ("ctx_normalize_trait_ref: " + ^ ctx.trait_ref_to_string trait_ref + ^ "\n- raw trait ref:\n" + ^ T.show_trait_ref ctx.pp_r trait_ref)); + let { T.trait_id; generics; trait_decl_ref } = trait_ref in + (* Check if the id is an impl, otherwise normalize it *) + let trait_id, norm_trait_ref = ctx_normalize_trait_instance_id ctx trait_id in + match norm_trait_ref with + | None -> + log#ldebug + (lazy + ("ctx_normalize_trait_ref: no norm: " + ^ ctx.trait_instance_id_to_string trait_id)); + let generics = ctx_normalize_generic_args ctx generics in + let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in + { T.trait_id; generics; trait_decl_ref } + | Some trait_ref -> + log#ldebug + (lazy + ("ctx_normalize_trait_ref: normalized to: " + ^ ctx.trait_ref_to_string trait_ref)); + assert (generics = TypesUtils.mk_empty_generic_args); + trait_ref + +(* Not sure this one is really necessary *) +and ctx_normalize_trait_decl_ref (ctx : 'r norm_ctx) + (trait_decl_ref : 'r T.trait_decl_ref) : 'r T.trait_decl_ref = + let { T.trait_decl_id; decl_generics } = trait_decl_ref in + let decl_generics = ctx_normalize_generic_args ctx decl_generics in + { T.trait_decl_id; decl_generics } + +let ctx_normalize_trait_type_constraint (ctx : 'r norm_ctx) + (ttc : 'r T.trait_type_constraint) : 'r T.trait_type_constraint = + let { T.trait_ref; generics; type_name; ty } = ttc in + let trait_ref = ctx_normalize_trait_ref ctx trait_ref in + let generics = ctx_normalize_generic_args ctx generics in + let ty = ctx_normalize_ty ctx ty in + { T.trait_ref; generics; type_name; ty } + +let generic_params_to_string ctx x = + "<" ^ String.concat ", " (fst (PA.generic_params_to_strings ctx x)) ^ ">" + +let mk_snorm_ctx (ctx : C.eval_ctx) : T.RegionVarId.id T.region norm_ctx = + let get_ty_repr x = C.STraitTypeRefMap.find_opt x ctx.norm_trait_stypes in + { + ctx; + get_ty_repr; + convert_ety = TypesUtils.ety_no_regions_to_sty; + convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; + ty_to_string = PA.sty_to_string ctx; + generic_params_to_string = generic_params_to_string ctx; + generic_args_to_string = PA.sgeneric_args_to_string ctx; + trait_ref_to_string = PA.strait_ref_to_string ctx; + trait_instance_id_to_string = PA.strait_instance_id_to_string ctx; + pp_r = T.pp_region T.pp_region_var_id; + } + +let mk_rnorm_ctx (ctx : C.eval_ctx) : T.RegionId.id T.region norm_ctx = + let get_ty_repr x = C.RTraitTypeRefMap.find_opt x ctx.norm_trait_rtypes in + { + ctx; + get_ty_repr; + convert_ety = TypesUtils.ety_no_regions_to_rty; + convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; + ty_to_string = PA.rty_to_string ctx; + generic_params_to_string = generic_params_to_string ctx; + generic_args_to_string = PA.rgeneric_args_to_string ctx; + trait_ref_to_string = PA.rtrait_ref_to_string ctx; + trait_instance_id_to_string = PA.rtrait_instance_id_to_string ctx; + pp_r = T.pp_region T.pp_region_id; + } + +let mk_enorm_ctx (ctx : C.eval_ctx) : T.erased_region norm_ctx = + let get_ty_repr x = C.ETraitTypeRefMap.find_opt x ctx.norm_trait_etypes in + { + ctx; + get_ty_repr; + convert_ety = (fun x -> x); + convert_etrait_ref = (fun x -> x); + ty_to_string = PA.ety_to_string ctx; + generic_params_to_string = generic_params_to_string ctx; + generic_args_to_string = PA.egeneric_args_to_string ctx; + trait_ref_to_string = PA.etrait_ref_to_string ctx; + trait_instance_id_to_string = PA.etrait_instance_id_to_string ctx; + pp_r = T.pp_erased_region; + } + +let ctx_normalize_sty (ctx : C.eval_ctx) (ty : T.sty) : T.sty = + ctx_normalize_ty (mk_snorm_ctx ctx) ty + +let ctx_normalize_rty (ctx : C.eval_ctx) (ty : T.rty) : T.rty = + ctx_normalize_ty (mk_rnorm_ctx ctx) ty + +let ctx_normalize_ety (ctx : C.eval_ctx) (ty : T.ety) : T.ety = + ctx_normalize_ty (mk_enorm_ctx ctx) ty + +let ctx_normalize_rtrait_type_constraint (ctx : C.eval_ctx) + (ttc : T.rtrait_type_constraint) : T.rtrait_type_constraint = + ctx_normalize_trait_type_constraint (mk_rnorm_ctx ctx) ttc + +(** Same as [type_decl_get_instantiated_variants_fields_rtypes] but normalizes the types *) +let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) + (def : T.type_decl) (generics : T.rgeneric_args) : + (T.VariantId.id option * T.rty list) list = + let res = + Subst.type_decl_get_instantiated_variants_fields_rtypes def generics + in + List.map + (fun (variant_id, types) -> + (variant_id, List.map (ctx_normalize_rty ctx) types)) + res + +(** Same as [type_decl_get_instantiated_field_rtypes] but normalizes the types *) +let type_decl_get_inst_norm_field_rtypes (ctx : C.eval_ctx) (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) (generics : T.rgeneric_args) : + T.rty list = + let types = + Subst.type_decl_get_instantiated_field_rtypes def opt_variant_id generics + in + List.map (ctx_normalize_rty ctx) types + +(** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) +let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) + (adt : V.adt_value) (id : T.type_id) (generics : T.rgeneric_args) : + T.rty list = + let types = + Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id generics + in + List.map (ctx_normalize_rty ctx) types + +(** Same as [ctx_adt_value_get_instantiated_field_etypes] but normalizes the types *) +let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) (generics : T.egeneric_args) : + T.ety list = + let types = + Subst.type_decl_get_instantiated_field_etypes def opt_variant_id generics + in + List.map (ctx_normalize_ety ctx) types + +(** Same as [ctx_adt_get_instantiated_field_etypes] but normalizes the types *) +let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) + (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) + (generics : T.egeneric_args) : T.ety list = + let types = + Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id + generics + in + List.map (ctx_normalize_ety ctx) types + +(** Same as [substitute_signature] but normalizes the types *) +let ctx_subst_norm_signature (ctx : C.eval_ctx) + (asubst : T.RegionGroupId.id -> V.AbstractionId.id) + (r_subst : T.RegionVarId.id -> T.RegionId.id) + (ty_subst : T.TypeVarId.id -> T.rty) + (cg_subst : T.ConstGenericVarId.id -> T.const_generic) + (tr_subst : T.TraitClauseId.id -> T.rtrait_instance_id) + (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + let sg = + Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self + sg + in + let { A.regions_hierarchy; inputs; output; trait_type_constraints } = sg in + let inputs = List.map (ctx_normalize_rty ctx) inputs in + let output = ctx_normalize_rty ctx output in + let trait_type_constraints = + List.map (ctx_normalize_rtrait_type_constraint ctx) trait_type_constraints + in + { regions_hierarchy; inputs; output; trait_type_constraints } diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 11cd5666..79f6b0d4 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -63,200 +63,52 @@ module Sig = struct let empty_const_generic_params : T.const_generic_var list = [] + let mk_generic_args regions types const_generics : T.sgeneric_args = + { regions; types; const_generics; trait_refs = [] } + + let mk_generic_params regions types const_generics : T.generic_params = + { regions; types; const_generics; trait_clauses = [] } + let mk_ref_ty (r : T.RegionVarId.id T.region) (ty : T.sty) (is_mut : bool) : T.sty = let ref_kind = if is_mut then T.Mut else T.Shared in mk_ref_ty r ty ref_kind let mk_array_ty (ty : T.sty) (cg : T.const_generic) : T.sty = - Adt (Assumed Array, [], [ ty ], [ cg ]) + Adt (Assumed Array, mk_generic_args [] [ ty ] [ cg ]) - let mk_slice_ty (ty : T.sty) : T.sty = Adt (Assumed Slice, [], [ ty ], []) - let range_ty : T.sty = Adt (Assumed Range, [], [ usize_ty ], []) + let mk_slice_ty (ty : T.sty) : T.sty = + Adt (Assumed Slice, mk_generic_args [] [ ty ] []) - (** [fn<T>(&'a mut T, T) -> T] *) - let mem_replace_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] (* <'a> *) in - let regions_hierarchy = [ region_group_0 ] (* [{<'a>}] *) in - let type_params = [ type_param_0 ] (* <T> *) in - let inputs = - [ mk_ref_ty rvar_0 tvar_0 true (* &'a mut T *); tvar_0 (* T *) ] + let mk_sig generics regions_hierarchy inputs output : A.fun_sig = + let preds : T.predicates = + { regions_outlive = []; types_outlive = []; trait_type_constraints = [] } in - let output = tvar_0 (* T *) in { - region_params; - num_early_bound_regions = 0; + is_unsafe = false; + generics; + preds; + parent_params_info = None; regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; inputs; output; } (** [fn<T>(T) -> Box<T>] *) let box_new_sig : A.fun_sig = - { - region_params = []; - num_early_bound_regions = 0; - regions_hierarchy = []; - type_params = [ type_param_0 ] (* <T> *); - const_generic_params = empty_const_generic_params; - inputs = [ tvar_0 (* T *) ]; - output = mk_box_ty tvar_0 (* Box<T> *); - } + let generics = mk_generic_params [] [ type_param_0 ] [] (* <T> *) in + let regions_hierarchy = [] in + let inputs = [ tvar_0 (* T *) ] in + let output = mk_box_ty tvar_0 (* Box<T> *) in + mk_sig generics regions_hierarchy inputs output (** [fn<T>(Box<T>) -> ()] *) let box_free_sig : A.fun_sig = - { - region_params = []; - num_early_bound_regions = 0; - regions_hierarchy = []; - type_params = [ type_param_0 ] (* <T> *); - const_generic_params = empty_const_generic_params; - inputs = [ mk_box_ty tvar_0 (* Box<T> *) ]; - output = mk_unit_ty (* () *); - } - - (** Helper for [Box::deref_shared] and [Box::deref_mut]. - Returns: - [fn<'a, T>(&'a (mut) Box<T>) -> &'a (mut) T] - *) - let box_deref_gen_sig (is_mut : bool) : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params = [ type_param_0 ] (* <T> *); - const_generic_params = empty_const_generic_params; - inputs = - [ mk_ref_ty rvar_0 (mk_box_ty tvar_0) is_mut (* &'a (mut) Box<T> *) ]; - output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *); - } - - (** [fn<'a, T>(&'a Box<T>) -> &'a T] *) - let box_deref_shared_sig = box_deref_gen_sig false - - (** [fn<'a, T>(&'a mut Box<T>) -> &'a mut T] *) - let box_deref_mut_sig = box_deref_gen_sig true - - (** [fn<T>() -> Vec<T>] *) - let vec_new_sig : A.fun_sig = - let region_params = [] in + let generics = mk_generic_params [] [ type_param_0 ] [] (* <T> *) in let regions_hierarchy = [] in - let type_params = [ type_param_0 ] (* <T> *) in - let inputs = [] in - let output = mk_vec_ty tvar_0 (* Vec<T> *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } - - (** [fn<T>(&'a mut Vec<T>, T)] *) - let vec_push_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* <T> *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec<T> *); - tvar_0 (* T *); - ] - in + let inputs = [ mk_box_ty tvar_0 (* Box<T> *) ] in let output = mk_unit_ty (* () *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } - - (** [fn<T>(&'a mut Vec<T>, usize, T)] *) - let vec_insert_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* <T> *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec<T> *); - mk_usize_ty (* usize *); - tvar_0 (* T *); - ] - in - let output = mk_unit_ty (* () *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } - - (** [fn<T>(&'a Vec<T>) -> usize] *) - let vec_len_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* <T> *) in - let inputs = - [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) false (* &'a Vec<T> *) ] - in - let output = mk_usize_ty (* usize *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } - - (** Helper: - [fn<T>(&'a (mut) Vec<T>, usize) -> &'a (mut) T] - *) - let vec_index_gen_sig (is_mut : bool) : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* <T> *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) is_mut (* &'a (mut) Vec<T> *); - mk_usize_ty (* usize *); - ] - in - let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } - - (** [fn<T>(&'a Vec<T>, usize) -> &'a T] *) - let vec_index_shared_sig : A.fun_sig = vec_index_gen_sig false - - (** [fn<T>(&'a mut Vec<T>, usize) -> &'a mut T] *) - let vec_index_mut_sig : A.fun_sig = vec_index_gen_sig true + mk_sig generics regions_hierarchy inputs output (** Array/slice functions *) @@ -275,10 +127,10 @@ module Sig = struct let mk_array_slice_borrow_sig (cgs : T.const_generic_var list) (input_ty : T.TypeVarId.id -> T.sty) (index_ty : T.sty option) (output_ty : T.TypeVarId.id -> T.sty) (is_mut : bool) : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] cgs (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* <T> *) in let inputs = [ mk_ref_ty rvar_0 @@ -294,15 +146,7 @@ module Sig = struct (output_ty type_param_0.index) is_mut (* &'a (mut) output_ty<T> *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - const_generic_params = cgs; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output let mk_array_slice_index_sig (is_array : bool) (is_mut : bool) : A.fun_sig = (* Array<T, N> *) @@ -328,50 +172,53 @@ module Sig = struct let cgs = [ cg_param_0 ] in mk_array_slice_borrow_sig cgs input_ty None output_ty is_mut - let mk_array_slice_subslice_sig (is_array : bool) (is_mut : bool) : A.fun_sig - = - (* Array<T, N> *) - let input_ty id = - if is_array then mk_array_ty (T.TypeVar id) cgvar_0 - else mk_slice_ty (T.TypeVar id) + let array_repeat_sig = + let generics = + (* <T, N> *) + mk_generic_params [] [ type_param_0 ] [ cg_param_0 ] in - (* Range *) - let index_ty = range_ty in - (* Slice<T> *) - let output_ty id = mk_slice_ty (T.TypeVar id) in - let cgs = if is_array then [ cg_param_0 ] else [] in - mk_array_slice_borrow_sig cgs input_ty (Some index_ty) output_ty is_mut - - let array_subslice_sig (is_mut : bool) = - mk_array_slice_subslice_sig true is_mut - - let slice_subslice_sig (is_mut : bool) = - mk_array_slice_subslice_sig false is_mut + let regions_hierarchy = [] (* <> *) in + let inputs = [ tvar_0 (* T *) ] in + let output = + (* [T; N] *) + mk_array_ty tvar_0 cgvar_0 + in + mk_sig generics regions_hierarchy inputs output (** Helper: [fn<T>(&'a [T]) -> usize] *) let slice_len_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* <T> *) in let inputs = [ mk_ref_ty rvar_0 (mk_slice_ty tvar_0) false (* &'a [T] *) ] in let output = mk_usize_ty (* usize *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output end -type assumed_info = A.assumed_fun_id * A.fun_sig * bool * name +type raw_assumed_fun_info = + A.assumed_fun_id * A.fun_sig * bool * name * bool list option + +type assumed_fun_info = { + fun_id : A.assumed_fun_id; + fun_sig : A.fun_sig; + can_fail : bool; + name : name; + keep_types : bool list option; + (** We may want to filter some type arguments. + + For instance, all the `Vec` functions (and the `Vec` type itself) take + an `Allocator` type as argument, that we ignore. + *) +} + +let mk_assumed_fun_info (raw : raw_assumed_fun_info) : assumed_fun_info = + let fun_id, fun_sig, can_fail, name, keep_types = raw in + { fun_id; fun_sig; can_fail; name; keep_types } (** The list of assumed functions and all their information: - their signature @@ -384,94 +231,72 @@ type assumed_info = A.assumed_fun_id * A.fun_sig * bool * name a [usize], we have to make sure that vectors are bounded by the max usize. As a consequence, [Vec::push] is monadic. *) -let assumed_infos : assumed_info list = - let deref_pre = [ "core"; "ops"; "deref" ] in - let vec_pre = [ "alloc"; "vec"; "Vec" ] in - let index_pre = [ "core"; "ops"; "index" ] in +let raw_assumed_fun_infos : raw_assumed_fun_info list = [ - (A.Replace, Sig.mem_replace_sig, false, to_name [ "core"; "mem"; "replace" ]); - (BoxNew, Sig.box_new_sig, false, to_name [ "alloc"; "boxed"; "Box"; "new" ]); + ( BoxNew, + Sig.box_new_sig, + false, + to_name [ "alloc"; "boxed"; "Box"; "new" ], + Some [ true; false ] ); + (* BoxFree shouldn't be used *) ( BoxFree, Sig.box_free_sig, false, - to_name [ "alloc"; "boxed"; "Box"; "free" ] ); - ( BoxDeref, - Sig.box_deref_shared_sig, - false, - to_name (deref_pre @ [ "Deref"; "deref" ]) ); - ( BoxDerefMut, - Sig.box_deref_mut_sig, - false, - to_name (deref_pre @ [ "DerefMut"; "deref_mut" ]) ); - (VecNew, Sig.vec_new_sig, false, to_name (vec_pre @ [ "new" ])); - (VecPush, Sig.vec_push_sig, true, to_name (vec_pre @ [ "push" ])); - (VecInsert, Sig.vec_insert_sig, true, to_name (vec_pre @ [ "insert" ])); - (VecLen, Sig.vec_len_sig, false, to_name (vec_pre @ [ "len" ])); - ( VecIndex, - Sig.vec_index_shared_sig, - true, - to_name (index_pre @ [ "Index"; "index" ]) ); - ( VecIndexMut, - Sig.vec_index_mut_sig, - true, - to_name (index_pre @ [ "IndexMut"; "index_mut" ]) ); + to_name [ "alloc"; "boxed"; "Box"; "free" ], + Some [ true; false ] ); (* Array Index *) ( ArrayIndexShared, Sig.array_index_sig false, true, - to_name [ "@ArrayIndexShared" ] ); - (ArrayIndexMut, Sig.array_index_sig true, true, to_name [ "@ArrayIndexMut" ]); + to_name [ "@ArrayIndexShared" ], + None ); + ( ArrayIndexMut, + Sig.array_index_sig true, + true, + to_name [ "@ArrayIndexMut" ], + None ); (* Array to slice*) ( ArrayToSliceShared, Sig.array_to_slice_sig false, true, - to_name [ "@ArrayToSliceShared" ] ); + to_name [ "@ArrayToSliceShared" ], + None ); ( ArrayToSliceMut, Sig.array_to_slice_sig true, true, - to_name [ "@ArrayToSliceMut" ] ); - (* Array Subslice *) - ( ArraySubsliceShared, - Sig.array_subslice_sig false, - true, - to_name [ "@ArraySubsliceShared" ] ); - ( ArraySubsliceMut, - Sig.array_subslice_sig true, - true, - to_name [ "@ArraySubsliceMut" ] ); + to_name [ "@ArrayToSliceMut" ], + None ); + (* Array Repeat *) + (ArrayRepeat, Sig.array_repeat_sig, false, to_name [ "@ArrayRepeat" ], None); (* Slice Index *) ( SliceIndexShared, Sig.slice_index_sig false, true, - to_name [ "@SliceIndexShared" ] ); - (SliceIndexMut, Sig.slice_index_sig true, true, to_name [ "@SliceIndexMut" ]); - (* Slice Subslice *) - ( SliceSubsliceShared, - Sig.slice_subslice_sig false, - true, - to_name [ "@SliceSubsliceShared" ] ); - ( SliceSubsliceMut, - Sig.slice_subslice_sig true, + to_name [ "@SliceIndexShared" ], + None ); + ( SliceIndexMut, + Sig.slice_index_sig true, true, - to_name [ "@SliceSubsliceMut" ] ); - (SliceLen, Sig.slice_len_sig, false, to_name [ "@SliceLen" ]); + to_name [ "@SliceIndexMut" ], + None ); + (SliceLen, Sig.slice_len_sig, false, to_name [ "@SliceLen" ], None); ] -let get_assumed_info (id : A.assumed_fun_id) : assumed_info = - match List.find_opt (fun (id', _, _, _) -> id = id') assumed_infos with +let assumed_fun_infos : assumed_fun_info list = + List.map mk_assumed_fun_info raw_assumed_fun_infos + +let get_assumed_fun_info (id : A.assumed_fun_id) : assumed_fun_info = + match List.find_opt (fun x -> id = x.fun_id) assumed_fun_infos with | Some info -> info | None -> raise - (Failure ("get_assumed_info: not found: " ^ A.show_assumed_fun_id id)) + (Failure ("get_assumed_fun_info: not found: " ^ A.show_assumed_fun_id id)) -let get_assumed_sig (id : A.assumed_fun_id) : A.fun_sig = - let _, sg, _, _ = get_assumed_info id in - sg +let get_assumed_fun_sig (id : A.assumed_fun_id) : A.fun_sig = + (get_assumed_fun_info id).fun_sig -let get_assumed_name (id : A.assumed_fun_id) : fun_name = - let _, _, _, name = get_assumed_info id in - name +let get_assumed_fun_name (id : A.assumed_fun_id) : fun_name = + (get_assumed_fun_info id).name -let assumed_can_fail (id : A.assumed_fun_id) : bool = - let _, _, b, _ = get_assumed_info id in - b +let assumed_fun_can_fail (id : A.assumed_fun_id) : bool = + (get_assumed_fun_info id).can_fail diff --git a/compiler/Config.ml b/compiler/Config.ml index bd80769f..a487f9e2 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -124,7 +124,7 @@ let always_deconstruct_adts_with_matches = ref false (** Controls whether we need to use a state to model the external world (I/O, for instance). *) -let use_state = ref true +let use_state = ref false (** Controls whether we use fuel to control termination. *) @@ -160,7 +160,7 @@ let backward_no_state_update = ref false files for the types, clauses and functions, or if we group them in one file. *) -let split_files = ref true +let split_files = ref false (** Generate the library entry point, if the crate is split between different files. @@ -306,13 +306,6 @@ let filter_useless_monadic_calls = ref true *) let filter_useless_functions = ref true -(** Obsolete. TODO: remove. - - For Lean we used to parameterize the entire development by a section variable - called opaque_defs, of type OpaqueDefs. - *) -let wrap_opaque_in_sig = ref false - (** Use short names for the record fields. Some backends can't disambiguate records when their field names have collisions. @@ -323,3 +316,23 @@ let wrap_opaque_in_sig = ref false information), we use short names (i.e., the original field names). *) let record_fields_short_names = ref false + +(** Parameterize the traits with their associated types, so as not to use + types as first class objects. + + This is useful for some backends with limited expressiveness like HOL4, + and to account for type constraints (like [fn f<T : Foo>(...) where T::bar = usize]). + *) +let parameterize_trait_types = ref false + +(** For sanity check: type check the generated pure code (activates checks in + several places). + + TODO: deactivated for now because we need to implement the normalization of + trait associated types in the pure code. + *) +let type_check_pure_code = ref false + +(** Shall we fail hard if we encounter an issue, or should we attempt to go + as far as possible while leaving "holes" in the generated code? *) +let fail_hard = ref true diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 2ca5653d..dac64a9a 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -5,6 +5,7 @@ open LlbcAst module V = Values open ValuesUtils open Identifiers +module L = Logging (** The [Id] module for dummy variables. @@ -17,6 +18,9 @@ IdGen () type dummy_var_id = DummyVarId.id [@@deriving show, ord] +(** The local logger *) +let log = L.contexts_log + (** Some global counters. Note that those counters were initially stored in {!eval_ctx} values, @@ -40,6 +44,7 @@ type dummy_var_id = DummyVarId.id [@@deriving show, ord] fn f x : fun_type = let id = fresh_id () in ... + fun () -> ... let g = f x in // <-- the fresh identifier gets generated here let x1 = g () in // <-- no fresh generation here @@ -250,27 +255,127 @@ type type_context = { } [@@deriving show] -type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] +type fun_context = { + fun_decls : fun_decl FunDeclId.Map.t; + fun_infos : FunsAnalysis.fun_info FunDeclId.Map.t; +} +[@@deriving show] type global_context = { global_decls : global_decl GlobalDeclId.Map.t } [@@deriving show] +type trait_decls_context = { trait_decls : trait_decl TraitDeclId.Map.t } +[@@deriving show] + +type trait_impls_context = { trait_impls : trait_impl TraitImplId.Map.t } +[@@deriving show] + +type decls_ctx = { + type_ctx : type_context; + fun_ctx : fun_context; + global_ctx : global_context; + trait_decls_ctx : trait_decls_context; + trait_impls_ctx : trait_impls_context; +} +[@@deriving show] + +(** A reference to a trait associated type *) +type 'r trait_type_ref = { trait_ref : 'r trait_ref; type_name : string } +[@@deriving show, ord] + +type etrait_type_ref = erased_region trait_type_ref [@@deriving show, ord] + +type rtrait_type_ref = Types.RegionId.id Types.region trait_type_ref +[@@deriving show, ord] + +type strait_type_ref = Types.RegionVarId.id Types.region trait_type_ref +[@@deriving show, ord] + +(* TODO: correctly use the functors so as not to have a duplication below *) +module ETraitTypeRefOrd = struct + type t = etrait_type_ref + + let compare = compare_etrait_type_ref + let to_string = show_etrait_type_ref + let pp_t = pp_etrait_type_ref + let show_t = show_etrait_type_ref +end + +module RTraitTypeRefOrd = struct + type t = rtrait_type_ref + + let compare = compare_rtrait_type_ref + let to_string = show_rtrait_type_ref + let pp_t = pp_rtrait_type_ref + let show_t = show_rtrait_type_ref +end + +module STraitTypeRefOrd = struct + type t = strait_type_ref + + let compare = compare_strait_type_ref + let to_string = show_strait_type_ref + let pp_t = pp_strait_type_ref + let show_t = show_strait_type_ref +end + +module ETraitTypeRefMap = Collections.MakeMap (ETraitTypeRefOrd) +module RTraitTypeRefMap = Collections.MakeMap (RTraitTypeRefOrd) +module STraitTypeRefMap = Collections.MakeMap (STraitTypeRefOrd) + (** Evaluation context *) type eval_ctx = { type_context : type_context; fun_context : fun_context; global_context : global_context; + trait_decls_context : trait_decls_context; + trait_impls_context : trait_impls_context; region_groups : RegionGroupId.id list; type_vars : type_var list; const_generic_vars : const_generic_var list; + const_generic_vars_map : typed_value Types.ConstGenericVarId.Map.t; + (** The map from const generic vars to their values. Those values + can be symbolic values or concrete values (in the latter case: + if we run in interpreter mode) *) + norm_trait_etypes : ety ETraitTypeRefMap.t; + (** The normalized trait types (a map from trait types to their representatives). + Note that this doesn't support account higher-order types. *) + norm_trait_rtypes : rty RTraitTypeRefMap.t; + (** We need this because we manipulate two kinds of types. + Note that we actually forbid regions from appearing both in the trait + references and in the constraints given to the associated types, + meaning that we don't have to worry about mismatches due to changes + in region ids. + + TODO: how not to duplicate? + *) + norm_trait_stypes : sty STraitTypeRefMap.t; + (** We sometimes need to normalize types in non-instantiated signatures. + + Note that we either need to use the etypes/rtypes maps, or the stypes map. + This means that we either compute the maps for etypes and rtypes, or compute + the one for stypes (we don't always compute and carry all the maps). + *) env : env; ended_regions : RegionId.Set.t; } [@@deriving show] +let lookup_type_var_opt (ctx : eval_ctx) (vid : TypeVarId.id) : type_var option + = + if TypeVarId.to_int vid < List.length ctx.type_vars then + Some (TypeVarId.nth ctx.type_vars vid) + else None + let lookup_type_var (ctx : eval_ctx) (vid : TypeVarId.id) : type_var = TypeVarId.nth ctx.type_vars vid +let lookup_const_generic_var_opt (ctx : eval_ctx) (vid : ConstGenericVarId.id) : + const_generic_var option = + if ConstGenericVarId.to_int vid < List.length ctx.const_generic_vars then + Some (ConstGenericVarId.nth ctx.const_generic_vars vid) + else None + let lookup_const_generic_var (ctx : eval_ctx) (vid : ConstGenericVarId.id) : const_generic_var = ConstGenericVarId.nth ctx.const_generic_vars vid @@ -304,6 +409,12 @@ let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : global_decl = GlobalDeclId.Map.find gid ctx.global_context.global_decls +let ctx_lookup_trait_decl (ctx : eval_ctx) (id : TraitDeclId.id) : trait_decl = + TraitDeclId.Map.find id ctx.trait_decls_context.trait_decls + +let ctx_lookup_trait_impl (ctx : eval_ctx) (id : TraitImplId.id) : trait_impl = + TraitImplId.Map.find id ctx.trait_impls_context.trait_impls + (** Retrieve a variable's value in the current frame *) let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = snd (env_lookup_var env vid) @@ -312,6 +423,11 @@ let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = let ctx_lookup_var_value (ctx : eval_ctx) (vid : VarId.id) : typed_value = env_lookup_var_value ctx.env vid +(** Retrieve a const generic value in an evaluation context *) +let ctx_lookup_const_generic_value (ctx : eval_ctx) (vid : ConstGenericVarId.id) + : typed_value = + Types.ConstGenericVarId.Map.find vid ctx.const_generic_vars_map + (** Update a variable's value in the current frame. This is a helper function: it can break invariants and doesn't perform @@ -361,6 +477,15 @@ let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = *) let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx = + log#ldebug + (lazy + ("push_vars:\n" + ^ String.concat "\n" + (List.map + (fun (var, value) -> + (* We can unfortunately not use Print because it depends on Contexts... *) + show_var var ^ " -> " ^ V.show_typed_value value) + vars))); assert ( List.for_all (fun (var, (value : typed_value)) -> var.var_ty = value.ty) diff --git a/compiler/Driver.ml b/compiler/Driver.ml index b646a53d..128ae890 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -17,11 +17,15 @@ let log = main_log let _ = (* Set up the logging - for now we use default values - TODO: use the * command-line arguments *) - (* By setting a level for the main_logger_handler, we filter everything *) + (* By setting a level for the main_logger_handler, we filter everything. + To have a good trace: one should switch between Info and Debug. + *) Easy_logging.Handlers.set_level main_logger_handler EL.Debug; main_log#set_level EL.Info; llbc_of_json_logger#set_level EL.Info; pre_passes_log#set_level EL.Info; + associated_types_log#set_level EL.Info; + contexts_log#set_level EL.Info; interpreter_log#set_level EL.Info; statements_log#set_level EL.Info; loops_match_ctxs_log#set_level EL.Info; @@ -37,7 +41,7 @@ let _ = pure_utils_log#set_level EL.Info; symbolic_to_pure_log#set_level EL.Info; pure_micro_passes_log#set_level EL.Info; - pure_to_extract_log#set_level EL.Info; + extract_log#set_level EL.Info; translate_log#set_level EL.Info; scc_log#set_level EL.Info; reorder_decls_log#set_level EL.Info @@ -62,6 +66,9 @@ let () = (* Read the command line arguments *) let dest_dir = ref "" in + (* Print the imported llbc *) + let print_llbc = ref false in + let spec = [ ( "-backend", @@ -86,9 +93,9 @@ let () = Arg.Set extract_decreases_clauses, " Use decreases clauses/termination measures for the recursive \ definitions" ); - ( "-no-state", - Arg.Clear use_state, - " Do not use state-error monads, simply use error monads" ); + ( "-state", + Arg.Set use_state, + " Use a *state*-error monads, instead of an error monads" ); ( "-use-fuel", Arg.Set use_fuel, " Use a fuel parameter to control divergence" ); @@ -99,10 +106,10 @@ let () = Arg.Set extract_template_decreases_clauses, " Generate templates for the required decreases clauses/termination \ measures, in a dedicated file. Implies -decreases-clauses" ); - ( "-no-split-files", - Arg.Clear split_files, - " Do not split the definitions between different files for types, \ - functions, etc." ); + ( "-split-files", + Arg.Set split_files, + " Split the definitions between different files for types, functions, \ + etc." ); ( "-no-check-inv", Arg.Clear check_invariants, " Deactivate the invariant sanity checks performed at every evaluation \ @@ -114,6 +121,8 @@ let () = ( "-lean-default-lakefile", Arg.Clear lean_gen_lakefile, " Generate a default lakefile.lean (Lean only)" ); + ("-print-llbc", Arg.Set print_llbc, " Print the imported LLBC"); + ("-k", Arg.Clear fail_hard, " Do not fail hard in case of error"); ] in @@ -127,6 +136,7 @@ let () = in if !extract_template_decreases_clauses then extract_decreases_clauses := true; + if !print_llbc then main_log#set_level EL.Debug; (* Sanity check (now that the arguments are parsed!): -template-clauses ==> decrease-clauses *) assert (!extract_decreases_clauses || not !extract_template_decreases_clauses); @@ -158,14 +168,14 @@ let () = | FStar -> (* Some patterns are not supported *) decompose_monadic_let_bindings := false; - decompose_nested_let_patterns := false + decompose_nested_let_patterns := false; + (* F* can disambiguate the field names *) + record_fields_short_names := true | Coq -> (* Some patterns are not supported *) decompose_monadic_let_bindings := true; decompose_nested_let_patterns := true | Lean -> - (* The Lean backend is experimental: print a warning *) - log#lwarning (lazy "The Lean backend is experimental"); (* We don't support fuel for the Lean backend *) if !use_fuel then ( log#error "The Lean backend doesn't support the -use-fuel option"; @@ -212,28 +222,6 @@ let () = log#linfo (lazy ("Imported: " ^ filename)); log#ldebug (lazy ("\n" ^ Print.Crate.crate_to_string m ^ "\n")); - (* Print a warning if the crate contains loops (loops are experimental for now) *) - let has_loops = - A.FunDeclId.Map.exists - (fun _ -> Aeneas.LlbcAstUtils.fun_decl_has_loops) - m.functions - in - if has_loops then log#lwarning (lazy "Support for loops is experimental"); - - (* If we target Lean, we request the crates to be split into several files - whenever there are opaque functions *) - if - !backend = Lean - && A.FunDeclId.Map.exists - (fun _ (d : A.fun_decl) -> d.body = None) - m.functions - && not !split_files - then ( - log#error - "For Lean, we request the -split-file option whenever using opaque \ - functions"; - fail ()); - (* We don't support mutually recursive definitions with decreases clauses in Lean *) if !backend = Lean && !extract_decreases_clauses diff --git a/compiler/Extract.ml b/compiler/Extract.ml index c4238d83..d04f5c1d 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -3,2102 +3,104 @@ the formatter everywhere... *) -open Utils open Pure open PureUtils open TranslateCore open ExtractBase -open StringUtils open Config -module F = Format - -(** Small helper to compute the name of an int type *) -let int_name (int_ty : integer_type) = - let isize, usize, i_format, u_format = - match !backend with - | FStar | Coq | HOL4 -> - ("isize", "usize", format_of_string "i%d", format_of_string "u%d") - | Lean -> ("Isize", "Usize", format_of_string "I%d", format_of_string "U%d") - in - match int_ty with - | Isize -> isize - | I8 -> Printf.sprintf i_format 8 - | I16 -> Printf.sprintf i_format 16 - | I32 -> Printf.sprintf i_format 32 - | I64 -> Printf.sprintf i_format 64 - | I128 -> Printf.sprintf i_format 128 - | Usize -> usize - | U8 -> Printf.sprintf u_format 8 - | U16 -> Printf.sprintf u_format 16 - | U32 -> Printf.sprintf u_format 32 - | U64 -> Printf.sprintf u_format 64 - | U128 -> Printf.sprintf u_format 128 - -(** Small helper to compute the name of a unary operation *) -let unop_name (unop : unop) : string = - match unop with - | Not -> ( - match !backend with FStar | Lean -> "not" | Coq -> "negb" | HOL4 -> "~") - | Neg (int_ty : integer_type) -> ( - match !backend with Lean -> "-" | _ -> int_name int_ty ^ "_neg") - | Cast _ -> - (* We never directly use the unop name in this case *) - raise (Failure "Unsupported") - -(** Small helper to compute the name of a binary operation (note that many - binary operations like "less than" are extracted to primitive operations, - like [<]). - *) -let named_binop_name (binop : E.binop) (int_ty : integer_type) : string = - let binop = - match binop with - | Div -> "div" - | Rem -> "rem" - | Add -> "add" - | Sub -> "sub" - | Mul -> "mul" - | Lt -> "lt" - | Le -> "le" - | Ge -> "ge" - | Gt -> "gt" - | _ -> raise (Failure "Unreachable") - in - (* Remark: the Lean case is actually not used *) - match !backend with - | Lean -> int_name int_ty ^ "." ^ binop - | FStar | Coq | HOL4 -> int_name int_ty ^ "_" ^ binop - -(** A list of keywords/identifiers used by the backend and with which we - want to check collision. - - Remark: this is useful mostly to look for collisions when generating - names for *variables*. - *) -let keywords () = - let named_unops = - unop_name Not - :: List.map (fun it -> unop_name (Neg it)) T.all_signed_int_types - in - let named_binops = [ E.Div; Rem; Add; Sub; Mul ] in - let named_binops = - List.concat_map - (fun bn -> List.map (fun it -> named_binop_name bn it) T.all_int_types) - named_binops - in - let misc = - match !backend with - | FStar -> - [ - "assert"; - "assert_norm"; - "assume"; - "else"; - "fun"; - "fn"; - "FStar"; - "FStar.Mul"; - "if"; - "in"; - "include"; - "int"; - "let"; - "list"; - "match"; - "not"; - "open"; - "rec"; - "scalar_cast"; - "then"; - "type"; - "Type0"; - "Type"; - "unit"; - "val"; - "with"; - ] - | Coq -> - [ - "assert"; - "Arguments"; - "Axiom"; - "char_of_byte"; - "Check"; - "Declare"; - "Definition"; - "else"; - "End"; - "fun"; - "Fixpoint"; - "if"; - "in"; - "int"; - "Inductive"; - "Import"; - "let"; - "Lemma"; - "match"; - "Module"; - "not"; - "Notation"; - "Proof"; - "Qed"; - "rec"; - "Record"; - "Require"; - "Scope"; - "Search"; - "SearchPattern"; - "Set"; - "then"; - (* [tt] is unit *) - "tt"; - "type"; - "Type"; - "unit"; - "with"; - ] - | Lean -> - [ - "by"; - "class"; - "decreasing_by"; - "def"; - "deriving"; - "do"; - "else"; - "end"; - "for"; - "have"; - "if"; - "inductive"; - "instance"; - "import"; - "let"; - "macro"; - "match"; - "namespace"; - "opaque"; - "open"; - "run_cmd"; - "set_option"; - "simp"; - "structure"; - "syntax"; - "termination_by"; - "then"; - "Type"; - "unsafe"; - "where"; - "with"; - "opaque_defs"; - ] - | HOL4 -> - [ - "Axiom"; - "case"; - "Definition"; - "else"; - "End"; - "fix"; - "fix_exec"; - "fn"; - "fun"; - "if"; - "in"; - "int"; - "Inductive"; - "let"; - "of"; - "Proof"; - "QED"; - "then"; - "Theorem"; - ] - in - List.concat [ named_unops; named_binops; misc ] - -let assumed_adts () : (assumed_ty * string) list = - match !backend with - | Lean -> - [ - (State, "State"); - (Result, "Result"); - (Error, "Error"); - (Fuel, "Nat"); - (Option, "Option"); - (Vec, "Vec"); - (Array, "Array"); - (Slice, "Slice"); - (Str, "Str"); - (Range, "Range"); - ] - | Coq | FStar -> - [ - (State, "state"); - (Result, "result"); - (Error, "error"); - (Fuel, "nat"); - (Option, "option"); - (Vec, "vec"); - (Array, "array"); - (Slice, "slice"); - (Str, "str"); - (Range, "range"); - ] - | HOL4 -> - [ - (State, "state"); - (Result, "result"); - (Error, "error"); - (Fuel, "num"); - (Option, "option"); - (Vec, "vec"); - (Array, "array"); - (Slice, "slice"); - (Str, "str"); - (Range, "range"); - ] - -let assumed_struct_constructors () : (assumed_ty * string) list = - match !backend with - | Lean -> [ (Range, "Range.mk"); (Array, "Array.make") ] - | Coq -> [ (Range, "mk_range"); (Array, "mk_array") ] - | FStar -> [ (Range, "Mkrange"); (Array, "mk_array") ] - | HOL4 -> [ (Range, "mk_range"); (Array, "mk_array") ] - -let assumed_variants () : (assumed_ty * VariantId.id * string) list = - match !backend with - | FStar -> - [ - (Result, result_return_id, "Return"); - (Result, result_fail_id, "Fail"); - (Error, error_failure_id, "Failure"); - (Error, error_out_of_fuel_id, "OutOfFuel"); - (* No Fuel::Zero on purpose *) - (* No Fuel::Succ on purpose *) - (Option, option_some_id, "Some"); - (Option, option_none_id, "None"); - ] - | Coq -> - [ - (Result, result_return_id, "Return"); - (Result, result_fail_id, "Fail_"); - (Error, error_failure_id, "Failure"); - (Error, error_out_of_fuel_id, "OutOfFuel"); - (Fuel, fuel_zero_id, "O"); - (Fuel, fuel_succ_id, "S"); - (Option, option_some_id, "Some"); - (Option, option_none_id, "None"); - ] - | Lean -> - [ - (Result, result_return_id, "ret"); - (Result, result_fail_id, "fail"); - (Error, error_failure_id, "panic"); - (* No Fuel::Zero on purpose *) - (* No Fuel::Succ on purpose *) - (Option, option_some_id, "some"); - (Option, option_none_id, "none"); - ] - | HOL4 -> - [ - (Result, result_return_id, "Return"); - (Result, result_fail_id, "Fail"); - (Error, error_failure_id, "Failure"); - (* No Fuel::Zero on purpose *) - (* No Fuel::Succ on purpose *) - (Option, option_some_id, "SOME"); - (Option, option_none_id, "NONE"); - ] - -let assumed_llbc_functions () : - (A.assumed_fun_id * T.RegionGroupId.id option * string) list = - let rg0 = Some T.RegionGroupId.zero in - match !backend with - | FStar | Coq | HOL4 -> - [ - (Replace, None, "mem_replace_fwd"); - (Replace, rg0, "mem_replace_back"); - (VecNew, None, "vec_new"); - (VecPush, None, "vec_push_fwd") (* Shouldn't be used *); - (VecPush, rg0, "vec_push_back"); - (VecInsert, None, "vec_insert_fwd") (* Shouldn't be used *); - (VecInsert, rg0, "vec_insert_back"); - (VecLen, None, "vec_len"); - (VecIndex, None, "vec_index_fwd"); - (VecIndex, rg0, "vec_index_back") (* shouldn't be used *); - (VecIndexMut, None, "vec_index_mut_fwd"); - (VecIndexMut, rg0, "vec_index_mut_back"); - (ArrayIndexShared, None, "array_index_shared"); - (ArrayIndexMut, None, "array_index_mut_fwd"); - (ArrayIndexMut, rg0, "array_index_mut_back"); - (ArrayToSliceShared, None, "array_to_slice_shared"); - (ArrayToSliceMut, None, "array_to_slice_mut_fwd"); - (ArrayToSliceMut, rg0, "array_to_slice_mut_back"); - (ArraySubsliceShared, None, "array_subslice_shared"); - (ArraySubsliceMut, None, "array_subslice_mut_fwd"); - (ArraySubsliceMut, rg0, "array_subslice_mut_back"); - (SliceIndexShared, None, "slice_index_shared"); - (SliceIndexMut, None, "slice_index_mut_fwd"); - (SliceIndexMut, rg0, "slice_index_mut_back"); - (SliceSubsliceShared, None, "slice_subslice_shared"); - (SliceSubsliceMut, None, "slice_subslice_mut_fwd"); - (SliceSubsliceMut, rg0, "slice_subslice_mut_back"); - (SliceLen, None, "slice_len"); - ] - | Lean -> - [ - (Replace, None, "mem.replace"); - (Replace, rg0, "mem.replace_back"); - (VecNew, None, "Vec.new"); - (VecPush, None, "Vec.push_fwd") (* Shouldn't be used *); - (VecPush, rg0, "Vec.push"); - (VecInsert, None, "Vec.insert_fwd") (* Shouldn't be used *); - (VecInsert, rg0, "Vec.insert"); - (VecLen, None, "Vec.len"); - (VecIndex, None, "Vec.index_shared"); - (VecIndex, rg0, "Vec.index_shared_back") (* shouldn't be used *); - (VecIndexMut, None, "Vec.index_mut"); - (VecIndexMut, rg0, "Vec.index_mut_back"); - (ArrayIndexShared, None, "Array.index_shared"); - (ArrayIndexMut, None, "Array.index_mut"); - (ArrayIndexMut, rg0, "Array.index_mut_back"); - (ArrayToSliceShared, None, "Array.to_slice_shared"); - (ArrayToSliceMut, None, "Array.to_slice_mut"); - (ArrayToSliceMut, rg0, "Array.to_slice_mut_back"); - (ArraySubsliceShared, None, "Array.subslice_shared"); - (ArraySubsliceMut, None, "Array.subslice_mut"); - (ArraySubsliceMut, rg0, "Array.subslice_mut_back"); - (SliceIndexShared, None, "Slice.index_shared"); - (SliceIndexMut, None, "Slice.index_mut"); - (SliceIndexMut, rg0, "Slice.index_mut_back"); - (SliceSubsliceShared, None, "Slice.subslice_shared"); - (SliceSubsliceMut, None, "Slice.subslice_mut"); - (SliceSubsliceMut, rg0, "Slice.subslice_mut_back"); - (SliceLen, None, "Slice.len"); - ] - -let assumed_pure_functions () : (pure_assumed_fun_id * string) list = - match !backend with - | FStar -> - [ - (Return, "return"); - (Fail, "fail"); - (Assert, "massert"); - (FuelDecrease, "decrease"); - (FuelEqZero, "is_zero"); - ] - | Coq -> - (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) - [ (Return, "return_"); (Fail, "fail_"); (Assert, "massert") ] - | Lean -> - (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) - [ (Return, "return"); (Fail, "fail_"); (Assert, "massert") ] - | HOL4 -> - (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) - [ (Return, "return"); (Fail, "fail"); (Assert, "massert") ] - -let names_map_init () : names_map_init = - { - keywords = keywords (); - assumed_adts = assumed_adts (); - assumed_structs = assumed_struct_constructors (); - assumed_variants = assumed_variants (); - assumed_llbc_functions = assumed_llbc_functions (); - assumed_pure_functions = assumed_pure_functions (); - } - -let extract_unop (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit - = - match unop with - | Not | Neg _ -> - let unop = unop_name unop in - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt unop; - F.pp_print_space fmt (); - extract_expr true arg; - if inside then F.pp_print_string fmt ")" - | Cast (src, tgt) -> ( - (* HOL4 has a special treatment: because it doesn't support dependent - types, we don't have a specific operator for the cast *) - match !backend with - | HOL4 -> - (* Casting, say, an u32 to an i32 would be done as follows: - {[ - mk_i32 (u32_to_int x) - ]} - *) - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt ("mk_" ^ int_name tgt); - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - F.pp_print_string fmt (int_name src ^ "_to_int"); - F.pp_print_space fmt (); - extract_expr true arg; - F.pp_print_string fmt ")"; - if inside then F.pp_print_string fmt ")" - | FStar | Coq | Lean -> - (* Rem.: the source type is an implicit parameter *) - if inside then F.pp_print_string fmt "("; - let cast_str = - match !backend with - | Coq | FStar -> "scalar_cast" - | Lean -> (* TODO: I8.cast, I16.cast, etc.*) "Scalar.cast" - | HOL4 -> raise (Failure "Unreachable") - in - F.pp_print_string fmt cast_str; - F.pp_print_space fmt (); - if !backend <> Lean then ( - F.pp_print_string fmt - (StringUtils.capitalize_first_letter - (PrintPure.integer_type_to_string src)); - F.pp_print_space fmt ()); - if !backend = Lean then F.pp_print_string fmt ("." ^ int_name tgt) - else - F.pp_print_string fmt - (StringUtils.capitalize_first_letter - (PrintPure.integer_type_to_string tgt)); - F.pp_print_space fmt (); - extract_expr true arg; - if inside then F.pp_print_string fmt ")") - -(** [extract_expr] : the boolean argument is [inside] *) -let extract_binop (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (binop : E.binop) - (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = - if inside then F.pp_print_string fmt "("; - (* Some binary operations have a special notation depending on the backend *) - (match (!backend, binop) with - | HOL4, (Eq | Ne) - | (FStar | Coq | Lean), (Eq | Lt | Le | Ne | Ge | Gt) - | Lean, (Div | Rem | Add | Sub | Mul) -> - let binop = - match binop with - | Eq -> "=" - | Lt -> "<" - | Le -> "<=" - | Ne -> if !backend = Lean then "!=" else "<>" - | Ge -> ">=" - | Gt -> ">" - | Div -> "/" - | Rem -> "%" - | Add -> "+" - | Sub -> "-" - | Mul -> "*" - | _ -> raise (Failure "Unreachable") - in - let binop = - match !backend with FStar | Lean | HOL4 -> binop | Coq -> "s" ^ binop - in - extract_expr false arg0; - F.pp_print_space fmt (); - F.pp_print_string fmt binop; - F.pp_print_space fmt (); - extract_expr false arg1 - | _, (Lt | Le | Ge | Gt | Div | Rem | Add | Sub | Mul) -> - let binop = named_binop_name binop int_ty in - F.pp_print_string fmt binop; - F.pp_print_space fmt (); - extract_expr true arg0; - F.pp_print_space fmt (); - extract_expr true arg1 - | _, (BitXor | BitAnd | BitOr | Shl | Shr) -> raise Unimplemented); - if inside then F.pp_print_string fmt ")" - -let type_decl_kind_to_qualif (kind : decl_kind) - (type_kind : type_decl_kind option) : string option = - match !backend with - | FStar -> ( - match kind with - | SingleNonRec -> Some "type" - | SingleRec -> Some "type" - | MutRecFirst -> Some "type" - | MutRecInner -> Some "and" - | MutRecLast -> Some "and" - | Assumed -> Some "assume type" - | Declared -> Some "val") - | Coq -> ( - match (kind, type_kind) with - | SingleNonRec, Some Enum -> Some "Inductive" - | SingleNonRec, Some Struct -> Some "Record" - | (SingleRec | MutRecFirst), Some _ -> Some "Inductive" - | (MutRecInner | MutRecLast), Some _ -> - (* Coq doesn't support groups of mutually recursive definitions which mix - * records and inducties: we convert everything to records if this happens - *) - Some "with" - | (Assumed | Declared), None -> Some "Axiom" - | _ -> raise (Failure "Unexpected")) - | Lean -> ( - match kind with - | SingleNonRec -> - if type_kind = Some Struct then Some "structure" else Some "inductive" - | SingleRec -> Some "inductive" - | MutRecFirst -> Some "inductive" - | MutRecInner -> Some "inductive" - | MutRecLast -> Some "inductive" - | Assumed -> Some "axiom" - | Declared -> Some "axiom") - | HOL4 -> None - -let fun_decl_kind_to_qualif (kind : decl_kind) : string option = - match !backend with - | FStar -> ( - match kind with - | SingleNonRec -> Some "let" - | SingleRec -> Some "let rec" - | MutRecFirst -> Some "let rec" - | MutRecInner -> Some "and" - | MutRecLast -> Some "and" - | Assumed -> Some "assume val" - | Declared -> Some "val") - | Coq -> ( - match kind with - | SingleNonRec -> Some "Definition" - | SingleRec -> Some "Fixpoint" - | MutRecFirst -> Some "Fixpoint" - | MutRecInner -> Some "with" - | MutRecLast -> Some "with" - | Assumed -> Some "Axiom" - | Declared -> Some "Axiom") - | Lean -> ( - match kind with - | SingleNonRec -> Some "def" - | SingleRec -> Some "divergent def" - | MutRecFirst -> Some "mutual divergent def" - | MutRecInner -> Some "divergent def" - | MutRecLast -> Some "divergent def" - | Assumed -> Some "axiom" - | Declared -> Some "axiom") - | HOL4 -> None - -(** The type of types. - - TODO: move inside the formatter? - *) -let type_keyword () = - match !backend with - | FStar -> "Type0" - | Coq | Lean -> "Type" - | HOL4 -> raise (Failure "Unexpected") - -(** - [ctx]: we use the context to lookup type definitions, to retrieve type names. - This is used to compute variable names, when they have no basenames: in this - case we use the first letter of the type name. - - [variant_concatenate_type_name]: if true, add the type name as a prefix - to the variant names. - Ex.: - In Rust: - {[ - enum List = { - Cons(u32, Box<List>),x - Nil, - } - ]} - - F*, if option activated: - {[ - type list = - | ListCons : u32 -> list -> list - | ListNil : list - ]} - - F*, if option not activated: - {[ - type list = - | Cons : u32 -> list -> list - | Nil : list - ]} - - Rk.: this should be true by default, because in Rust all the variant names - are actively uniquely identifier by the type name [List::Cons(...)], while - in other languages it is not necessarily the case, and thus clashes can mess - up type checking. Note that some languages actually forbids the name clashes - (it is the case of F* ). - *) -let mk_formatter (ctx : trans_ctx) (crate_name : string) - (variant_concatenate_type_name : bool) : formatter = - let int_name = int_name in - - (* Prepare a name. - * The first id elem is always the crate: if it is the local crate, - * we remove it. - * We also remove all the disambiguators, then convert everything to strings. - * **Rmk:** because we remove the disambiguators, there may be name collisions - * (which is ok, because we check for name collisions and fail if there is any). - *) - let get_name (name : name) : string list = - (* Rmk.: initially we only filtered the disambiguators equal to 0 *) - let name = Names.filter_disambiguators name in - match name with - | Ident crate :: name -> - let name = if crate = crate_name then name else Ident crate :: name in - let name = - List.map - (function - | Names.Ident s -> s - | Disambiguator d -> Names.Disambiguator.to_string d) - name - in - name - | _ -> - raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) - in - let get_type_name = get_name in - let type_name_to_camel_case name = - let name = get_type_name name in - let name = List.map to_camel_case name in - String.concat "" name - in - let type_name_to_snake_case name = - let name = get_type_name name in - let name = List.map to_snake_case name in - let name = String.concat "_" name in - match !backend with - | FStar | Lean | HOL4 -> name - | Coq -> capitalize_first_letter name - in - let type_name name = - match !backend with - | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_t" - | Lean -> String.concat "." (get_type_name name) - in - let field_name (def_name : name) (field_id : FieldId.id) - (field_name : string option) : string = - let field_name = - match field_name with - | Some field_name -> field_name - | None -> FieldId.to_string field_id - in - if !Config.record_fields_short_names then field_name - else - let def_name = type_name_to_snake_case def_name ^ "_" in - def_name ^ field_name - in - let variant_name (def_name : name) (variant : string) : string = - match !backend with - | FStar | Coq | HOL4 -> - let variant = to_camel_case variant in - if variant_concatenate_type_name then - type_name_to_camel_case def_name ^ variant - else variant - | Lean -> variant - in - let struct_constructor (basename : name) : string = - let tname = type_name basename in - let prefix = - match !backend with FStar -> "Mk" | Coq | HOL4 -> "mk" | Lean -> "" - in - let suffix = - match !backend with FStar | Coq | HOL4 -> "" | Lean -> ".mk" - in - prefix ^ tname ^ suffix - in - let get_fun_name fname = - let fname = get_name fname in - (* TODO: don't convert to snake case for Coq, HOL4, F* *) - match !backend with - | FStar | Coq | HOL4 -> String.concat "_" (List.map to_snake_case fname) - | Lean -> String.concat "." fname - in - let global_name (name : global_name) : string = - (* Converting to snake case also lowercases the letters (in Rust, global - * names are written in capital letters). *) - let parts = List.map to_snake_case (get_name name) in - String.concat "_" parts - in - let fun_name (fname : fun_name) (num_loops : int) (loop_id : LoopId.id option) - (num_rgs : int) (rg : region_group_info option) (filter_info : bool * int) - : string = - let fname = get_fun_name fname in - (* Compute the suffix *) - let suffix = default_fun_suffix num_loops loop_id num_rgs rg filter_info in - (* Concatenate *) - fname ^ suffix - in - - let termination_measure_name (_fid : A.FunDeclId.id) (fname : fun_name) - (num_loops : int) (loop_id : LoopId.id option) : string = - let fname = get_fun_name fname in - let lp_suffix = default_fun_loop_suffix num_loops loop_id in - (* Compute the suffix *) - let suffix = - match !Config.backend with - | FStar -> "_decreases" - | Lean -> "_terminates" - | Coq | HOL4 -> raise (Failure "Unexpected") - in - (* Concatenate *) - fname ^ lp_suffix ^ suffix - in - - let decreases_proof_name (_fid : A.FunDeclId.id) (fname : fun_name) - (num_loops : int) (loop_id : LoopId.id option) : string = - let fname = get_fun_name fname in - let lp_suffix = default_fun_loop_suffix num_loops loop_id in - (* Compute the suffix *) - let suffix = - match !Config.backend with - | Lean -> "_decreases" - | FStar | Coq | HOL4 -> raise (Failure "Unexpected") - in - (* Concatenate *) - fname ^ lp_suffix ^ suffix - in - - let opaque_pre () = - match !Config.backend with - | FStar | Coq | HOL4 -> "" - | Lean -> if !Config.wrap_opaque_in_sig then "opaque_defs." else "" - in - - let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) - : string = - (* If there is a basename, we use it *) - match basename with - | Some basename -> - (* This should be a no-op *) - to_snake_case basename - | None -> ( - (* No basename: we use the first letter of the type *) - match ty with - | Adt (type_id, tys, _) -> ( - match type_id with - | Tuple -> - (* The "pair" case is frequent enough to have its special treatment *) - if List.length tys = 2 then "p" else "t" - | Assumed Result -> "r" - | Assumed Error -> ConstStrings.error_basename - | Assumed Fuel -> ConstStrings.fuel_basename - | Assumed Option -> "opt" - | Assumed Vec -> "v" - | Assumed Array -> "a" - | Assumed Slice -> "s" - | Assumed Str -> "s" - | Assumed Range -> "r" - | Assumed State -> ConstStrings.state_basename - | AdtId adt_id -> - let def = - TypeDeclId.Map.find adt_id ctx.type_context.type_decls - in - (* We do the following: - * - compute the type name, and retrieve the last ident - * - convert this to snake case - * - take the first letter of every "letter group" - * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" - *) - (* Thename shouldn't be empty, and its last element should - * be an ident *) - let cl = List.nth def.name (List.length def.name - 1) in - let cl = to_snake_case (Names.as_ident cl) in - let cl = String.split_on_char '_' cl in - let cl = List.filter (fun s -> String.length s > 0) cl in - assert (List.length cl > 0); - let cl = List.map (fun s -> s.[0]) cl in - StringUtils.string_of_chars cl) - | TypeVar _ -> ( - (* TODO: use "t" also for F* *) - match !backend with - | FStar -> "x" (* lacking inspiration here... *) - | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) - | Literal lty -> ( - match lty with Bool -> "b" | Char -> "c" | Integer _ -> "i") - | Arrow _ -> "f") - in - let type_var_basename (_varset : StringSet.t) (basename : string) : string = - (* Rust type variables are snake-case and start with a capital letter *) - match !backend with - | FStar -> - (* This is *not* a no-op: this removes the capital letter *) - to_snake_case basename - | HOL4 -> - (* In HOL4, type variable names must start with "'" *) - "'" ^ to_snake_case basename - | Coq | Lean -> basename - in - let const_generic_var_basename (_varset : StringSet.t) (basename : string) : - string = - (* Rust type variables are snake-case and start with a capital letter *) - match !backend with - | FStar | HOL4 -> - (* This is *not* a no-op: this removes the capital letter *) - to_snake_case basename - | Coq | Lean -> basename - in - let append_index (basename : string) (i : int) : string = - basename ^ string_of_int i - in - - let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit - = - match cv with - | Scalar sv -> ( - match !backend with - | FStar -> F.pp_print_string fmt (Z.to_string sv.PV.value) - | Coq | HOL4 -> - let print_brackets = inside && !backend = HOL4 in - if print_brackets then F.pp_print_string fmt "("; - (match !backend with - | Coq -> () - | HOL4 -> - F.pp_print_string fmt ("int_to_" ^ int_name sv.PV.int_ty); - F.pp_print_space fmt () - | _ -> raise (Failure "Unreachable")); - (* We need to add parentheses if the value is negative *) - if sv.PV.value >= Z.of_int 0 then - F.pp_print_string fmt (Z.to_string sv.PV.value) - else F.pp_print_string fmt ("(" ^ Z.to_string sv.PV.value ^ ")"); - (match !backend with - | Coq -> F.pp_print_string fmt ("%" ^ int_name sv.PV.int_ty) - | HOL4 -> () - | _ -> raise (Failure "Unreachable")); - if print_brackets then F.pp_print_string fmt ")" - | Lean -> - F.pp_print_string fmt "("; - F.pp_print_string fmt (int_name sv.int_ty); - F.pp_print_string fmt ".ofInt "; - (* Something very annoying: negated values like `-3` are - ambiguous in Lean because of conversions, so we have to - be extremely explicit with negative numbers. - *) - if Z.lt sv.value Z.zero then ( - F.pp_print_string fmt "("; - F.pp_print_string fmt "-"; - F.pp_print_string fmt "("; - Z.pp_print fmt (Z.neg sv.value); - F.pp_print_string fmt ":Int"; - F.pp_print_string fmt ")"; - F.pp_print_string fmt ")") - else Z.pp_print fmt sv.value; - F.pp_print_string fmt ")") - | Bool b -> - let b = - match !backend with - | HOL4 -> if b then "T" else "F" - | Coq | FStar | Lean -> if b then "true" else "false" - in - F.pp_print_string fmt b - | Char c -> ( - match !backend with - | HOL4 -> - (* [#"a"] is a notation for [CHR 97] (97 is the ASCII code for 'a') *) - F.pp_print_string fmt ("#\"" ^ String.make 1 c ^ "\"") - | FStar | Lean -> F.pp_print_string fmt ("'" ^ String.make 1 c ^ "'") - | Coq -> - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt "char_of_byte"; - F.pp_print_space fmt (); - (* Convert the the char to ascii *) - let c = - let i = Char.code c in - let x0 = i / 16 in - let x1 = i mod 16 in - "Coq.Init.Byte.x" ^ string_of_int x0 ^ string_of_int x1 - in - F.pp_print_string fmt c; - if inside then F.pp_print_string fmt ")") - in - let bool_name = if !backend = Lean then "Bool" else "bool" in - let char_name = if !backend = Lean then "Char" else "char" in - let str_name = if !backend = Lean then "String" else "string" in - { - bool_name; - char_name; - int_name; - str_name; - type_decl_kind_to_qualif; - fun_decl_kind_to_qualif; - field_name; - variant_name; - struct_constructor; - type_name; - global_name; - fun_name; - termination_measure_name; - decreases_proof_name; - opaque_pre; - var_basename; - type_var_basename; - const_generic_var_basename; - append_index; - extract_literal; - extract_unop; - extract_binop; - } - -let mk_formatter_and_names_map (ctx : trans_ctx) (crate_name : string) - (variant_concatenate_type_name : bool) : formatter * names_map = - let fmt = mk_formatter ctx crate_name variant_concatenate_type_name in - let names_map = initialize_names_map fmt (names_map_init ()) in - (fmt, names_map) - -let is_single_opaque_fun_decl_group (dg : Pure.fun_decl list) : bool = - match dg with [ d ] -> d.body = None | _ -> false - -let is_single_opaque_type_decl_group (dg : Pure.type_decl list) : bool = - match dg with [ d ] -> d.kind = Opaque | _ -> false - -let is_empty_record_type_decl (d : Pure.type_decl) : bool = d.kind = Struct [] - -let is_empty_record_type_decl_group (dg : Pure.type_decl list) : bool = - match dg with [ d ] -> is_empty_record_type_decl d | _ -> false - -(** In some provers, groups of definitions must be delimited. - - - in Coq, *every* group (including singletons) must end with "." - - in Lean, groups of mutually recursive definitions must end with "end" - - in HOL4 (in most situations) the whole group must be within a `Define` command - - Calls to {!extract_fun_decl} should be inserted between calls to - {!start_fun_decl_group} and {!end_fun_decl_group}. - - TODO: maybe those [{start/end}_decl_group] functions are not that much a good - idea and we should merge them with the corresponding [extract_decl] functions. - *) -let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) - (is_rec : bool) (dg : Pure.fun_decl list) = - match !backend with - | FStar | Coq | Lean -> () - | HOL4 -> - (* In HOL4, opaque functions have a special treatment *) - if is_single_opaque_fun_decl_group dg then () - else - let with_opaque_pre = false in - let compute_fun_def_name (def : Pure.fun_decl) : string = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx - ^ "_def" - in - let names = List.map compute_fun_def_name dg in - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Open the box for the delimiters *) - F.pp_open_vbox fmt 0; - (* Open the box for the definitions themselves *) - F.pp_open_vbox fmt ctx.indent_incr; - (* Print the delimiters *) - if is_rec then - F.pp_print_string fmt - ("val [" ^ String.concat ", " names ^ "] = DefineDiv ‘") - else ( - assert (List.length names = 1); - let name = List.hd names in - F.pp_print_string fmt ("val " ^ name ^ " = Define ‘")); - F.pp_print_cut fmt () - -(** See {!start_fun_decl_group}. *) -let end_fun_decl_group (fmt : F.formatter) (is_rec : bool) - (dg : Pure.fun_decl list) = - match !backend with - | FStar -> () - | Coq -> - (* For aesthetic reasons, we print the Coq end group delimiter directly - in {!extract_fun_decl}. *) - () - | Lean -> - (* We must add the "end" keyword to groups of mutually recursive functions *) - if is_rec && List.length dg > 1 then ( - F.pp_print_cut fmt (); - F.pp_print_string fmt "end"; - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0) - else () - | HOL4 -> - (* In HOL4, opaque functions have a special treatment *) - if is_single_opaque_fun_decl_group dg then () - else ( - (* Close the box for the definitions *) - F.pp_close_box fmt (); - (* Print the end delimiter *) - F.pp_print_cut fmt (); - F.pp_print_string fmt "’"; - (* Close the box for the delimiters *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0) - -(** See {!start_fun_decl_group}: similar usage, but for the type declarations. *) -let start_type_decl_group (ctx : extraction_ctx) (fmt : F.formatter) - (is_rec : bool) (dg : Pure.type_decl list) = - match !backend with - | FStar | Coq -> () - | Lean -> - if is_rec && List.length dg > 1 then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "mutual"; - F.pp_print_space fmt ()) - | HOL4 -> - (* In HOL4, opaque types and empty records have a special treatment *) - if - is_single_opaque_type_decl_group dg - || is_empty_record_type_decl_group dg - then () - else ( - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Open the box for the delimiters *) - F.pp_open_vbox fmt 0; - (* Open the box for the definitions themselves *) - F.pp_open_vbox fmt ctx.indent_incr; - (* Print the delimiters *) - F.pp_print_string fmt "Datatype:"; - F.pp_print_cut fmt ()) - -(** See {!start_fun_decl_group}. *) -let end_type_decl_group (fmt : F.formatter) (is_rec : bool) - (dg : Pure.type_decl list) = - match !backend with - | FStar -> () - | Coq -> - (* For aesthetic reasons, we print the Coq end group delimiter directly - in {!extract_fun_decl}. *) - () - | Lean -> - (* We must add the "end" keyword to groups of mutually recursive functions *) - if is_rec && List.length dg > 1 then ( - F.pp_print_cut fmt (); - F.pp_print_string fmt "end"; - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0) - else () - | HOL4 -> - (* In HOL4, opaque types and empty records have a special treatment *) - if - is_single_opaque_type_decl_group dg - || is_empty_record_type_decl_group dg - then () - else ( - (* Close the box for the definitions *) - F.pp_close_box fmt (); - (* Print the end delimiter *) - F.pp_print_cut fmt (); - F.pp_print_string fmt "End"; - (* Close the box for the delimiters *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0) - -let unit_name () = - match !backend with Lean -> "Unit" | Coq | FStar | HOL4 -> "unit" - -(** Small helper *) -let extract_arrow (fmt : F.formatter) () : unit = - if !Config.backend = Lean then F.pp_print_string fmt "→" - else F.pp_print_string fmt "->" - -let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (cg : const_generic) : unit = - match cg with - | ConstGenericGlobal id -> - let s = ctx_get_global ctx.use_opaque_pre id ctx in - F.pp_print_string fmt s - | ConstGenericValue v -> ctx.fmt.extract_literal fmt inside v - | ConstGenericVar id -> - let s = ctx_get_const_generic_var id ctx in - F.pp_print_string fmt s - -let extract_literal_type (ctx : extraction_ctx) (fmt : F.formatter) - (ty : literal_type) : unit = - match ty with - | Bool -> F.pp_print_string fmt ctx.fmt.bool_name - | Char -> F.pp_print_string fmt ctx.fmt.char_name - | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) - -(** [inside] constrols whether we should add parentheses or not around type - applications (if [true] we add parentheses). - - [no_params_tys]: for all the types inside this set, do not print the type parameters. - This is used for HOL4. As polymorphism is uniform in HOL4, printing the - type parameters in the recursive definitions is useless (and actually - forbidden). - - For instance, where in F* we would write: - {[ - type list a = | Nil : list a | Cons : a -> list a -> list a - ]} - - In HOL4 we would simply write: - {[ - Datatype: - list = Nil 'a | Cons 'a list - End - ]} - *) -let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (ty : ty) : unit = - let extract_rec = extract_ty ctx fmt no_params_tys in - match ty with - | Adt (type_id, tys, cgs) -> ( - let has_params = tys <> [] || cgs <> [] in - match type_id with - | Tuple -> - (* This is a bit annoying, but in F*/Coq/HOL4 [()] is not the unit type: - * we have to write [unit]... *) - if tys = [] then F.pp_print_string fmt (unit_name ()) - else ( - F.pp_print_string fmt "("; - Collections.List.iter_link - (fun () -> - F.pp_print_space fmt (); - let product = - match !backend with - | FStar -> "&" - | Coq -> "*" - | Lean -> "×" - | HOL4 -> "#" - in - F.pp_print_string fmt product; - F.pp_print_space fmt ()) - (extract_rec true) tys; - F.pp_print_string fmt ")") - | AdtId _ | Assumed _ -> ( - (* HOL4 behaves differently. Where in Coq/FStar/Lean we would write: - `tree a b` - - In HOL4 we would write: - `('a, 'b) tree` - *) - let with_opaque_pre = false in - match !backend with - | FStar | Coq | Lean -> - let print_paren = inside && has_params in - if print_paren then F.pp_print_string fmt "("; - (* TODO: for now, only the opaque *functions* are extracted in the - opaque module. The opaque *types* are assumed. *) - F.pp_print_string fmt (ctx_get_type with_opaque_pre type_id ctx); - if tys <> [] then ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_rec true) tys); - if cgs <> [] then ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_const_generic ctx fmt true) - cgs); - if print_paren then F.pp_print_string fmt ")" - | HOL4 -> - (* Const generics are unsupported in HOL4 *) - assert (cgs = []); - let print_tys = - match type_id with - | AdtId id -> not (TypeDeclId.Set.mem id no_params_tys) - | Assumed _ -> true - | _ -> raise (Failure "Unreachable") - in - if tys <> [] && print_tys then ( - let print_paren = List.length tys > 1 in - if print_paren then F.pp_print_string fmt "("; - Collections.List.iter_link - (fun () -> - F.pp_print_string fmt ","; - F.pp_print_space fmt ()) - (extract_rec true) tys; - if print_paren then F.pp_print_string fmt ")"; - F.pp_print_space fmt ()); - F.pp_print_string fmt (ctx_get_type with_opaque_pre type_id ctx))) - | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) - | Literal lty -> extract_literal_type ctx fmt lty - | Arrow (arg_ty, ret_ty) -> - if inside then F.pp_print_string fmt "("; - extract_rec false arg_ty; - F.pp_print_space fmt (); - extract_arrow fmt (); - F.pp_print_space fmt (); - extract_rec false ret_ty; - if inside then F.pp_print_string fmt ")" - -(** Compute the names for all the top-level identifiers used in a type - definition (type name, variant names, field names, etc. but not type - parameters). - - We need to do this preemptively, beforce extracting any definition, - because of recursive definitions. - *) -let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : - extraction_ctx = - (* Compute and register the type def name *) - let ctx = ctx_add_type_decl def ctx in - (* Compute and register: - * - the variant names, if this is an enumeration - * - the field names, if this is a structure - *) - let ctx = - match def.kind with - | Struct fields -> - (* Add the fields *) - let ctx = - fst - (ctx_add_fields def (FieldId.mapi (fun id f -> (id, f)) fields) ctx) - in - (* Add the constructor name *) - fst (ctx_add_struct def ctx) - | Enum variants -> - fst - (ctx_add_variants def - (VariantId.mapi (fun id v -> (id, v)) variants) - ctx) - | Opaque -> - (* Nothing to do *) - ctx - in - (* Return *) - ctx - -(** Print the variants *) -let extract_type_decl_variant (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (type_name : string) - (type_params : string list) (cg_params : string list) (cons_name : string) - (fields : field list) : unit = - F.pp_print_space fmt (); - (* variant box *) - F.pp_open_hvbox fmt ctx.indent_incr; - (* [| Cons :] - * Note that we really don't want any break above so we print everything - * at once. *) - let opt_colon = if !backend <> HOL4 then " :" else "" in - F.pp_print_string fmt ("| " ^ cons_name ^ opt_colon); - let print_field (fid : FieldId.id) (f : field) (ctx : extraction_ctx) : - extraction_ctx = - F.pp_print_space fmt (); - (* Open the field box *) - F.pp_open_box fmt ctx.indent_incr; - (* Print the field names, if the backend accepts it. - * [ x :] - * Note that when printing fields, we register the field names as - * *variables*: they don't need to be unique at the top level. *) - let ctx = - match !backend with - | FStar -> ( - match f.field_name with - | None -> ctx - | Some field_name -> - let var_id = VarId.of_int (FieldId.to_int fid) in - let field_name = - ctx.fmt.var_basename ctx.names_map.names_set (Some field_name) - f.field_ty - in - let ctx, field_name = ctx_add_var field_name var_id ctx in - F.pp_print_string fmt (field_name ^ " :"); - F.pp_print_space fmt (); - ctx) - | Coq | Lean | HOL4 -> ctx - in - (* Print the field type *) - let inside = !backend = HOL4 in - extract_ty ctx fmt type_decl_group inside f.field_ty; - (* Print the arrow [->] *) - if !backend <> HOL4 then ( - F.pp_print_space fmt (); - extract_arrow fmt ()); - (* Close the field box *) - F.pp_close_box fmt (); - (* Return *) - ctx - in - (* Print the fields *) - let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in - let _ = - List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields - in - (* Sanity check: HOL4 doesn't support const generics *) - assert (cg_params = [] || !backend <> HOL4); - (* Print the final type *) - if !backend <> HOL4 then ( - F.pp_print_space fmt (); - F.pp_open_hovbox fmt 0; - F.pp_print_string fmt type_name; - List.iter - (fun p -> - F.pp_print_space fmt (); - F.pp_print_string fmt p) - (List.append type_params cg_params); - F.pp_close_box fmt ()); - (* Close the variant box *) - F.pp_close_box fmt () - -(* TODO: we don' need the [def_name] paramter: it can be retrieved from the context *) -let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (def : type_decl) (def_name : string) - (type_params : string list) (cg_params : string list) - (variants : variant list) : unit = - (* We want to generate a definition which looks like this (taking F* as example): - {[ - type list a = | Cons : a -> list a -> list a | Nil : list a - ]} - - If there isn't enough space on one line: - {[ - type s = - | Cons : a -> list a -> list a - | Nil : list a - ]} - - And if we need to write the type of a variant on several lines: - {[ - type s = - | Cons : - a -> - list a -> - list a - | Nil : list a - ]} - - Finally, it is possible to give names to the variant fields in Rust. - In this situation, we generate a definition like this: - {[ - type s = - | Cons : hd:a -> tl:list a -> list a - | Nil : list a - ]} - - Note that we already printed: [type s =] - *) - let print_variant _variant_id (v : variant) = - (* We don't lookup the name, because it may have a prefix for the type - id (in the case of Lean) *) - let cons_name = ctx.fmt.variant_name def.name v.variant_name in - let fields = v.fields in - extract_type_decl_variant ctx fmt type_decl_group def_name type_params - cg_params cons_name fields - in - (* Print the variants *) - let variants = VariantId.mapi (fun vid v -> (vid, v)) variants in - List.iter (fun (vid, v) -> print_variant vid v) variants - -let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) - (type_params : string list) (cg_params : string list) (fields : field list) - : unit = - (* We want to generate a definition which looks like this (taking F* as example): - {[ - type t = { x : int; y : bool; } - ]} - - If there isn't enough space on one line: - {[ - type t = - { - x : int; y : bool; - } - ]} - - And if there is even less space: - {[ - type t = - { - x : int; - y : bool; - } - ]} - - Also, in case there are no fields, we need to define the type as [unit] - ([type t = {}] doesn't work in F* ). - - Coq: - ==== - We need to define the constructor name upon defining the struct (record, in Coq). - The syntex is: - {[ - Record Foo = mkFoo { x : int; y : bool; }. - }] - - Also, Coq doesn't support groups of mutually recursive inductives and records. - This is fine, because we can then define records as inductives, and leverage - the fact that when record fields are accessed, the records are symbolically - expanded which introduces let bindings of the form: [let RecordCons ... = x in ...]. - As a consequence, we never use the record projectors (unless we reconstruct - them in the micro passes of course). - - HOL4: - ===== - Type definitions are written as follows: - {[ - Datatype: - tree = - TLeaf 'a - | TNode node ; - - node = - Node (tree list) - End - ]} - *) - (* Note that we already printed: [type t =] *) - let is_rec = decl_is_from_rec_group kind in - let _ = - if !backend = FStar && fields = [] then ( - F.pp_print_space fmt (); - F.pp_print_string fmt (unit_name ())) - else if !backend = Lean && fields = [] then () - (* If the definition is recursive, we may need to extract it as an inductive - (instead of a record). We start with the "normal" case: we extract it - as a record. *) - else if (not is_rec) || (!backend <> Coq && !backend <> Lean) then ( - if !backend <> Lean then F.pp_print_space fmt (); - (* If Coq: print the constructor name *) - (* TODO: remove superfluous test not is_rec below *) - if !backend = Coq && not is_rec then ( - let with_opaque_pre = false in - F.pp_print_string fmt - (ctx_get_struct with_opaque_pre (AdtId def.def_id) ctx); - F.pp_print_string fmt " "); - (match !backend with - | Lean -> () - | FStar | Coq -> F.pp_print_string fmt "{" - | HOL4 -> F.pp_print_string fmt "<|"); - F.pp_print_break fmt 1 ctx.indent_incr; - (* The body itself *) - (* Open a box for the body *) - (match !backend with - | Coq | FStar | HOL4 -> F.pp_open_hvbox fmt 0 - | Lean -> F.pp_open_vbox fmt 0); - (* Print the fields *) - let print_field (field_id : FieldId.id) (f : field) : unit = - let field_name = ctx_get_field (AdtId def.def_id) field_id ctx in - (* Open a box for the field *) - F.pp_open_box fmt ctx.indent_incr; - F.pp_print_string fmt field_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_ty ctx fmt type_decl_group false f.field_ty; - if !backend <> Lean then F.pp_print_string fmt ";"; - (* Close the box for the field *) - F.pp_close_box fmt () - in - let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in - Collections.List.iter_link (F.pp_print_space fmt) - (fun (fid, f) -> print_field fid f) - fields; - (* Close the box for the body *) - F.pp_close_box fmt (); - match !backend with - | Lean -> () - | FStar | Coq -> - F.pp_print_space fmt (); - F.pp_print_string fmt "}" - | HOL4 -> - F.pp_print_space fmt (); - F.pp_print_string fmt "|>") - else ( - (* We extract for Coq or Lean, and we have a recursive record, or a record in - a group of mutually recursive types: we extract it as an inductive type *) - assert (is_rec && (!backend = Coq || !backend = Lean)); - let with_opaque_pre = false in - (* Small trick: in Lean we use namespaces, meaning we don't need to prefix - the constructor name with the name of the type at definition site, - i.e., instead of generating `inductive Foo := | MkFoo ...` like in Coq - we generate `inductive Foo := | mk ... *) - let cons_name = - if !backend = Lean then "mk" - else ctx_get_struct with_opaque_pre (AdtId def.def_id) ctx - in - let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in - extract_type_decl_variant ctx fmt type_decl_group def_name type_params - cg_params cons_name fields) - in - () - -(** Extract a nestable, muti-line comment *) -let extract_comment (fmt : F.formatter) (sl : string list) : unit = - (* Delimiters, space after we break a line *) - let ld, space, rd = - match !backend with - | Coq | FStar | HOL4 -> ("(** ", 4, " *)") - | Lean -> ("/- ", 3, " -/") - in - F.pp_open_vbox fmt space; - F.pp_print_string fmt ld; - (match sl with - | [] -> () - | s :: sl -> - F.pp_print_string fmt s; - List.iter - (fun s -> - F.pp_print_space fmt (); - F.pp_print_string fmt s) - sl); - F.pp_print_string fmt rd; - F.pp_close_box fmt () - -(** Extract a type declaration. - - This function is for all type declarations and all backends **at the exception** - of opaque (assumed/declared) types format4 HOL4. - - See {!extract_type_decl}. - *) -let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) - (extract_body : bool) : unit = - (* Sanity check *) - assert (extract_body || !backend <> HOL4); - let type_kind = - if extract_body then - match def.kind with - | Struct _ -> Some Struct - | Enum _ -> Some Enum - | Opaque -> None - else None - in - (* If in Coq and the declaration is opaque, it must have the shape: - [Axiom Ident : forall (T0 ... Tn : Type) (N0 : ...) ... (Nn : ...), ... -> ... -> ...]. - - The boolean [is_opaque_coq] is used to detect this case. - *) - let is_opaque = type_kind = None in - let is_opaque_coq = !backend = Coq && is_opaque in - let use_forall = - is_opaque_coq && (def.type_params <> [] || def.const_generic_params <> []) - in - (* Retrieve the definition name *) - let with_opaque_pre = false in - let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in - (* Add the type and const generic params - note that we need those bindings only for the - * body translation (they are not top-level) *) - let ctx_body, type_params, cg_params = - ctx_add_type_const_generic_params def.type_params def.const_generic_params - ctx - in - let ty_cg_params = List.append type_params cg_params in - (* Add a break before *) - if !backend <> HOL4 || not (decl_is_first_from_group kind) then - F.pp_print_break fmt 0 0; - (* Print a comment to link the extracted type to its original rust definition *) - extract_comment fmt [ "[" ^ Print.name_to_string def.name ^ "]" ]; - F.pp_print_break fmt 0 0; - (* Open a box for the definition, so that whenever possible it gets printed on - * one line. Note however that in the case of Lean line breaks are important - * for parsing: we thus use a hovbox. *) - (match !backend with - | Coq | FStar | HOL4 -> F.pp_open_hvbox fmt 0 - | Lean -> F.pp_open_vbox fmt 0); - (* Open a box for "type TYPE_NAME (TYPE_PARAMS CONST_GEN_PARAMS) =" *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* > "type TYPE_NAME" *) - let qualif = ctx.fmt.type_decl_kind_to_qualif kind type_kind in - (match qualif with - | Some qualif -> F.pp_print_string fmt (qualif ^ " " ^ def_name) - | None -> F.pp_print_string fmt def_name); - (* HOL4 doesn't support const generics *) - assert (cg_params = [] || !backend <> HOL4); - (* Print the type/const generic parameters *) - if ty_cg_params <> [] && !backend <> HOL4 then ( - if use_forall then ( - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "forall"); - (* Print the type parameters *) - if type_params <> [] then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - List.iter - (fun s -> - F.pp_print_string fmt s; - F.pp_print_space fmt ()) - type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword () ^ ")")); - (* Print the const generic parameters *) - List.iter - (fun (var : const_generic_var) -> - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - let n = ctx_get_const_generic_var var.index ctx in - F.pp_print_string fmt n; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_literal_type ctx fmt var.ty; - F.pp_print_string fmt ")") - def.const_generic_params); - (* Print the "=" if we extract the body*) - if extract_body then ( - F.pp_print_space fmt (); - let eq = - match !backend with - | FStar -> "=" - | Coq -> ":=" - | Lean -> - if type_kind = Some Struct && kind = SingleNonRec then "where" - else ":=" - | HOL4 -> "=" - in - F.pp_print_string fmt eq) - else ( - (* Otherwise print ": Type", unless it is the HOL4 backend (in - which case we declare the type with `new_type`) *) - if use_forall then F.pp_print_string fmt "," - else ( - F.pp_print_space fmt (); - F.pp_print_string fmt ":"); - F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword ())); - (* Close the box for "type TYPE_NAME (TYPE_PARAMS) =" *) - F.pp_close_box fmt (); - (if extract_body then - match def.kind with - | Struct fields -> - extract_type_decl_struct_body ctx_body fmt type_decl_group kind def - type_params cg_params fields - | Enum variants -> - extract_type_decl_enum_body ctx_body fmt type_decl_group def def_name - type_params cg_params variants - | Opaque -> raise (Failure "Unreachable")); - (* Add the definition end delimiter *) - if !backend = HOL4 && decl_is_not_last_from_group kind then ( - F.pp_print_space fmt (); - F.pp_print_string fmt ";") - else if !backend = Coq && decl_is_last_from_group kind then ( - (* This is actually an end of group delimiter. For aesthetic reasons - we print it here instead of in {!end_type_decl_group}. *) - F.pp_print_cut fmt (); - F.pp_print_string fmt "."); - (* Close the box for the definition *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - if !backend <> HOL4 || decl_is_not_last_from_group kind then - F.pp_print_break fmt 0 0 - -(** Extract an opaque type declaration to HOL4. - - Remark (SH): having to treat this specific case separately is very annoying, - but I could not find a better way. - *) -let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) - (def : type_decl) : unit = - (* Retrieve the definition name *) - let with_opaque_pre = false in - let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in - (* Generic parameters are unsupported *) - assert (def.const_generic_params = []); - (* Count the number of parameters *) - let num_params = List.length def.type_params in - (* Generate the declaration *) - F.pp_print_space fmt (); - F.pp_print_string fmt - ("val _ = new_type (\"" ^ def_name ^ "\", " ^ string_of_int num_params ^ ")"); - F.pp_print_space fmt () - -(** Extract an empty record type declaration to HOL4. - - Empty records are not supported in HOL4, so we extract them as type - abbreviations to the unit type. - - Remark (SH): having to treat this specific case separately is very annoying, - but I could not find a better way. - *) -let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) - (fmt : F.formatter) (def : type_decl) : unit = - (* Retrieve the definition name *) - let with_opaque_pre = false in - let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in - (* Sanity check *) - assert (def.type_params = []); - assert (def.const_generic_params = []); - (* Generate the declaration *) - F.pp_print_space fmt (); - F.pp_print_string fmt ("Type " ^ def_name ^ " = “: unit”"); - F.pp_print_space fmt () - -(** Extract a type declaration. - - Note that all the names used for extraction should already have been - registered. - - This function should be inserted between calls to {!start_type_decl_group} - and {!end_type_decl_group}. - *) -let extract_type_decl (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) : - unit = - let extract_body = - match kind with - | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> true - | Assumed | Declared -> false - in - if extract_body then - if !backend = HOL4 && is_empty_record_type_decl def then - extract_type_decl_hol4_empty_record ctx fmt def - else extract_type_decl_gen ctx fmt type_decl_group kind def extract_body - else - match !backend with - | FStar | Coq | Lean -> - extract_type_decl_gen ctx fmt type_decl_group kind def extract_body - | HOL4 -> extract_type_decl_hol4_opaque ctx fmt def - -(** Auxiliary function. - - Generate [Arguments] instructions in Coq. - *) -let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) - (kind : decl_kind) (decl : type_decl) : unit = - assert (!backend = Coq); - (* Generating the [Arguments] instructions is useful only if there are type parameters *) - if decl.type_params = [] && decl.const_generic_params = [] then () - else - (* Add the type params - note that we need those bindings only for the - * body translation (they are not top-level) *) - let _ctx_body, type_params, cg_params = - ctx_add_type_const_generic_params decl.type_params - decl.const_generic_params ctx - in - (* Auxiliary function to extract an [Arguments Cons {T} _ _.] instruction *) - let extract_arguments_info (cons_name : string) (fields : 'a list) : unit = - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Open a box *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Small utility *) - let print_vars () = - List.iter - (fun (var : string) -> - F.pp_print_space fmt (); - F.pp_print_string fmt ("{" ^ var ^ "}")) - (List.append type_params cg_params) - in - let print_fields () = - List.iter - (fun _ -> - F.pp_print_space fmt (); - F.pp_print_string fmt "_") - fields - in - F.pp_print_break fmt 0 0; - F.pp_print_string fmt "Arguments"; - F.pp_print_space fmt (); - F.pp_print_string fmt cons_name; - print_vars (); - print_fields (); - F.pp_print_string fmt "."; - - (* Close the box *) - F.pp_close_box fmt () - in - - (* Generate the [Arguments] instruction *) - match decl.kind with - | Opaque -> () - | Struct fields -> - let adt_id = AdtId decl.def_id in - (* Generate the instruction for the record constructor *) - let with_opaque_pre = false in - let cons_name = ctx_get_struct with_opaque_pre adt_id ctx in - extract_arguments_info cons_name fields; - (* Generate the instruction for the record projectors, if there are *) - let is_rec = decl_is_from_rec_group kind in - if not is_rec then - FieldId.iteri - (fun fid _ -> - let cons_name = ctx_get_field adt_id fid ctx in - extract_arguments_info cons_name []) - fields; - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - | Enum variants -> - (* Generate the instructions *) - VariantId.iteri - (fun vid (v : variant) -> - let cons_name = ctx_get_variant (AdtId decl.def_id) vid ctx in - extract_arguments_info cons_name v.fields) - variants; - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - -(** Auxiliary function. - - Generate field projectors in Coq. - - Sometimes we extract records as inductives in Coq: when this happens we - have to define the field projectors afterwards. - *) -let extract_type_decl_record_field_projectors (ctx : extraction_ctx) - (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = - assert (!backend = Coq); - match decl.kind with - | Opaque | Enum _ -> () - | Struct fields -> - (* Records are extracted as inductives only if they are recursive *) - let is_rec = decl_is_from_rec_group kind in - if is_rec then - (* Add the type params *) - let ctx, type_params, cg_params = - ctx_add_type_const_generic_params decl.type_params - decl.const_generic_params ctx - in - let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in - let ctx, field_var = ctx_add_var "x" (VarId.of_int 1) ctx in - let with_opaque_pre = false in - let def_name = ctx_get_local_type with_opaque_pre decl.def_id ctx in - let cons_name = - ctx_get_struct with_opaque_pre (AdtId decl.def_id) ctx - in - let extract_field_proj (field_id : FieldId.id) (_ : field) : unit = - F.pp_print_space fmt (); - (* Outer box for the projector definition *) - F.pp_open_hvbox fmt 0; - (* Inner box for the projector definition *) - F.pp_open_hvbox fmt ctx.indent_incr; - (* Open a box for the [Definition PROJ ... :=] *) - F.pp_open_hovbox fmt ctx.indent_incr; - F.pp_print_string fmt "Definition"; - F.pp_print_space fmt (); - let field_name = ctx_get_field (AdtId decl.def_id) field_id ctx in - F.pp_print_string fmt field_name; - F.pp_print_space fmt (); - (* Print the type parameters *) - if type_params <> [] then ( - F.pp_print_string fmt "{"; - List.iter - (fun p -> - F.pp_print_string fmt p; - F.pp_print_space fmt ()) - type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type}"; - F.pp_print_space fmt ()); - (* Print the const generic parameters *) - if cg_params <> [] then - List.iter - (fun (v : const_generic_var) -> - F.pp_print_string fmt "{"; - let n = ctx_get_const_generic_var v.index ctx in - F.pp_print_string fmt n; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_literal_type ctx fmt v.ty; - F.pp_print_string fmt "}"; - F.pp_print_space fmt ()) - decl.const_generic_params; - (* Print the record parameter *) - F.pp_print_string fmt "("; - F.pp_print_string fmt record_var; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt def_name; - List.iter - (fun p -> - F.pp_print_space fmt (); - F.pp_print_string fmt p) - type_params; - F.pp_print_string fmt ")"; - (* *) - F.pp_print_space fmt (); - F.pp_print_string fmt ":="; - (* Close the box for the [Definition PROJ ... :=] *) - F.pp_close_box fmt (); - F.pp_print_space fmt (); - (* Open a box for the whole match *) - F.pp_open_hvbox fmt 0; - (* Open a box for the [match ... with] *) - F.pp_open_hovbox fmt ctx.indent_incr; - F.pp_print_string fmt "match"; - F.pp_print_space fmt (); - F.pp_print_string fmt record_var; - F.pp_print_space fmt (); - F.pp_print_string fmt "with"; - (* Close the box for the [match ... with] *) - F.pp_close_box fmt (); - - (* Open a box for the branch *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the match branch *) - F.pp_print_space fmt (); - F.pp_print_string fmt "|"; - F.pp_print_space fmt (); - F.pp_print_string fmt cons_name; - FieldId.iteri - (fun id _ -> - F.pp_print_space fmt (); - if field_id = id then F.pp_print_string fmt field_var - else F.pp_print_string fmt "_") - fields; - F.pp_print_space fmt (); - F.pp_print_string fmt "=>"; - F.pp_print_space fmt (); - F.pp_print_string fmt field_var; - (* Close the box for the branch *) - F.pp_close_box fmt (); - (* Print the [end] *) - F.pp_print_space fmt (); - F.pp_print_string fmt "end"; - (* Close the box for the whole match *) - F.pp_close_box fmt (); - (* Close the inner box projector *) - F.pp_close_box fmt (); - (* If Coq: end the definition with a "." *) - if !backend = Coq then ( - F.pp_print_cut fmt (); - F.pp_print_string fmt "."); - (* Close the outer box projector *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - in - - let extract_proj_notation (field_id : FieldId.id) (_ : field) : unit = - F.pp_print_space fmt (); - (* Outer box for the projector definition *) - F.pp_open_hvbox fmt 0; - (* Inner box for the projector definition *) - F.pp_open_hovbox fmt ctx.indent_incr; - let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in - F.pp_print_string fmt "Notation"; - F.pp_print_space fmt (); - let field_name = ctx_get_field (AdtId decl.def_id) field_id ctx in - F.pp_print_string fmt ("\"" ^ record_var ^ " .(" ^ field_name ^ ")\""); - F.pp_print_space fmt (); - F.pp_print_string fmt ":="; - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - F.pp_print_string fmt field_name; - F.pp_print_space fmt (); - F.pp_print_string fmt record_var; - F.pp_print_string fmt ")"; - F.pp_print_space fmt (); - F.pp_print_string fmt "(at level 9)"; - (* Close the inner box projector *) - F.pp_close_box fmt (); - (* If Coq: end the definition with a "." *) - if !backend = Coq then ( - F.pp_print_cut fmt (); - F.pp_print_string fmt "."); - (* Close the outer box projector *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - in - - let extract_field_proj_and_notation (field_id : FieldId.id) - (field : field) : unit = - extract_field_proj field_id field; - extract_proj_notation field_id field - in - - FieldId.iteri extract_field_proj_and_notation fields - -(** Extract extra information for a type (e.g., [Arguments] instructions in Coq). - - Note that all the names used for extraction should already have been - registered. - *) -let extract_type_decl_extra_info (ctx : extraction_ctx) (fmt : F.formatter) - (kind : decl_kind) (decl : type_decl) : unit = - match !backend with - | FStar | Lean | HOL4 -> () - | Coq -> - extract_type_decl_coq_arguments ctx fmt kind decl; - extract_type_decl_record_field_projectors ctx fmt kind decl - -(** Extract the state type declaration. *) -let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) - (kind : decl_kind) : unit = - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Print a comment *) - extract_comment fmt [ "The state type used in the state-error monad" ]; - F.pp_print_break fmt 0 0; - (* Open a box for the definition, so that whenever possible it gets printed on - * one line *) - F.pp_open_hvbox fmt 0; - (* Retrieve the name *) - let state_name = ctx_get_assumed_type State ctx in - (* The syntax for Lean and Coq is almost identical. *) - let print_axiom () = - let axiom = - match !backend with - | Coq -> "Axiom" - | Lean -> "axiom" - | FStar | HOL4 -> raise (Failure "Unexpected") - in - F.pp_print_string fmt axiom; - F.pp_print_space fmt (); - F.pp_print_string fmt state_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type"; - if !backend = Coq then F.pp_print_string fmt "." - in - (* The kind should be [Assumed] or [Declared] *) - (match kind with - | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> - raise (Failure "Unexpected") - | Assumed -> ( - match !backend with - | FStar -> - F.pp_print_string fmt "assume"; - F.pp_print_space fmt (); - F.pp_print_string fmt "type"; - F.pp_print_space fmt (); - F.pp_print_string fmt state_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0" - | HOL4 -> - F.pp_print_string fmt ("val _ = new_type (\"" ^ state_name ^ "\", 0)") - | Coq | Lean -> print_axiom ()) - | Declared -> ( - match !backend with - | FStar -> - F.pp_print_string fmt "val"; - F.pp_print_space fmt (); - F.pp_print_string fmt state_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0" - | HOL4 -> - F.pp_print_string fmt ("val _ = new_type (\"" ^ state_name ^ "\", 0)") - | Coq | Lean -> print_axiom ())); - (* Close the box for the definition *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 +include ExtractTypes (** Compute the names for all the pure functions generated from a rust function (forward function and backward functions). *) -let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) +let extract_fun_decl_register_names (ctx : extraction_ctx) (has_decreases_clause : fun_decl -> bool) (def : pure_fun_translation) : extraction_ctx = - let (fwd, loop_fwds), back_ls = def in - (* Register the decrease clauses, if necessary *) - let register_decreases ctx def = - if has_decreases_clause def then - (* Add the termination measure *) - let ctx = ctx_add_termination_measure def ctx in - (* Add the decreases proof for Lean only *) - match !Config.backend with - | Coq | FStar -> ctx - | HOL4 -> raise (Failure "Unexpected") - | Lean -> ctx_add_decreases_proof def ctx - else ctx - in - let ctx = List.fold_left register_decreases ctx (fwd :: loop_fwds) in - let register_fun ctx f = ctx_add_fun_decl (keep_fwd, def) f ctx in - let register_funs ctx fl = List.fold_left register_fun ctx fl in - (* Register the forward functions' names *) - let ctx = register_funs ctx (fwd :: loop_fwds) in - (* Register the backward functions' names *) - let ctx = - List.fold_left - (fun ctx (back, loop_backs) -> - let ctx = register_fun ctx back in - register_funs ctx loop_backs) - ctx back_ls - in - - (* Return *) - ctx + (* Ignore the trait methods **declarations** (rem.: we do not ignore the trait + method implementations): we do not need to refer to them directly. We will + only use their type for the fields of the records we generate for the trait + declarations *) + match def.fwd.f.kind with + | TraitMethodDecl _ -> ctx + | _ -> ( + (* Check if the function is builtin *) + let builtin = + let open ExtractBuiltin in + let funs_map = builtin_funs_map () in + let sname = name_to_simple_name def.fwd.f.basename in + SimpleNameMap.find_opt sname funs_map + in + (* Use the builtin names if necessary *) + match builtin with + | Some (filter_info, info) -> + (* Register the filtering information, if there is *) + let ctx = + match filter_info with + | Some keep -> + { + ctx with + funs_filter_type_args_map = + FunDeclId.Map.add def.fwd.f.def_id keep + ctx.funs_filter_type_args_map; + } + | _ -> ctx + in + let backs = List.map (fun f -> f.f) def.backs in + let funs = if def.keep_fwd then def.fwd.f :: backs else backs in + List.fold_left + (fun ctx (f : fun_decl) -> + let open ExtractBuiltin in + let fun_id = + (Pure.FunId (Regular f.def_id), f.loop_id, f.back_id) + in + let fun_info = + List.find_opt + (fun (x : builtin_fun_info) -> x.rg = f.back_id) + info + in + match fun_info with + | Some fun_info -> + ctx_add (FunId (FromLlbc fun_id)) fun_info.extract_name ctx + | None -> + raise + (Failure + ("Not found: " + ^ Names.name_to_string f.basename + ^ ", " + ^ Print.option_to_string Pure.show_loop_id f.loop_id + ^ Print.option_to_string Pure.show_region_group_id + f.back_id))) + ctx funs + | None -> + let fwd = def.fwd in + let backs = def.backs in + (* Register the decrease clauses, if necessary *) + let register_decreases ctx def = + if has_decreases_clause def then + (* Add the termination measure *) + let ctx = ctx_add_termination_measure def ctx in + (* Add the decreases proof for Lean only *) + match !Config.backend with + | Coq | FStar -> ctx + | HOL4 -> raise (Failure "Unexpected") + | Lean -> ctx_add_decreases_proof def ctx + else ctx + in + let ctx = + List.fold_left register_decreases ctx (fwd.f :: fwd.loops) + in + let register_fun ctx f = ctx_add_fun_decl def f ctx in + let register_funs ctx fl = List.fold_left register_fun ctx fl in + (* Register the names of the forward functions *) + let ctx = + if def.keep_fwd then register_funs ctx (fwd.f :: fwd.loops) else ctx + in + (* Register the names of the backward functions *) + List.fold_left + (fun ctx { f = back; loops = loop_backs } -> + let ctx = register_fun ctx back in + register_funs ctx loop_backs) + ctx backs) (** Simply add the global name to the context. *) let extract_global_decl_register_names (ctx : extraction_ctx) @@ -2122,11 +124,11 @@ let extract_adt_g_value (inside : bool) (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : extraction_ctx = match ty with - | Adt (Tuple, type_args, cg_args) -> + | Adt (Tuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) - assert (List.length type_args = List.length field_values); - assert (cg_args = []); + assert (List.length generics.types = List.length field_values); + assert (generics.const_generics = [] && generics.trait_refs = []); (* This is very annoying: in Coq, we can't write [()] for the value of type [unit], we have to write [tt]. *) if !backend = Coq && field_values = [] then ( @@ -2144,7 +146,7 @@ let extract_adt_g_value in F.pp_print_string fmt ")"; ctx) - | Adt (adt_id, _, _) -> + | Adt (adt_id, _) -> (* "Regular" ADT *) (* If we are generating a pattern for a let-binding and we target Lean, @@ -2172,18 +174,14 @@ let extract_adt_g_value * [{ field0=...; ...; fieldn=...; }] in case of structures. *) let cons = - (* The ADT shouldn't be opaque *) - let with_opaque_pre = false in match variant_id with | Some vid -> ( (* In the case of Lean, we might have to add the type name as a prefix *) match (!backend, adt_id) with | Lean, Assumed _ -> - ctx_get_type with_opaque_pre adt_id ctx - ^ "." - ^ ctx_get_variant adt_id vid ctx + ctx_get_type adt_id ctx ^ "." ^ ctx_get_variant adt_id vid ctx | _ -> ctx_get_variant adt_id vid ctx) - | None -> ctx_get_struct with_opaque_pre adt_id ctx + | None -> ctx_get_struct adt_id ctx in let use_parentheses = inside && field_values <> [] in if use_parentheses then F.pp_print_string fmt "("; @@ -2202,8 +200,33 @@ let extract_adt_g_value (* Extract globals in the same way as variables *) let extract_global (ctx : extraction_ctx) (fmt : F.formatter) (id : A.GlobalDeclId.id) : unit = - let with_opaque_pre = ctx.use_opaque_pre in - F.pp_print_string fmt (ctx_get_global with_opaque_pre id ctx) + F.pp_print_string fmt (ctx_get_global id ctx) + +(* Filter the generics of a function if it is builtin *) +let fun_builtin_filter_types (id : FunDeclId.id) (types : 'a list) + (ctx : extraction_ctx) : ('a list, 'a list * string) Result.result = + match FunDeclId.Map.find_opt id ctx.funs_filter_type_args_map with + | None -> Result.Ok types + | Some filter -> + if List.length filter <> List.length types then ( + let decl = FunDeclId.Map.find id ctx.trans_funs in + let err = + "Ill-formed builtin information for function " + ^ Names.name_to_string decl.fwd.f.basename + ^ ": " + ^ string_of_int (List.length filter) + ^ " filtering arguments provided for " + ^ string_of_int (List.length types) + ^ " type arguments" + in + log#serror err; + Result.Error (types, err)) + else + let types = List.combine filter types in + let types = + List.filter_map (fun (b, ty) -> if b then Some ty else None) types + in + Result.Ok types (** [inside]: see {!extract_ty}. @@ -2218,7 +241,7 @@ let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) ctx | PatVar (v, _) -> let vname = - ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty + ctx.fmt.var_basename ctx.names_maps.names_map.names_set v.basename v.ty in let ctx, vname = ctx_add_var vname v.id ctx in F.pp_print_string fmt vname; @@ -2249,6 +272,9 @@ let rec extract_texpression (ctx : extraction_ctx) (fmt : F.formatter) | Var var_id -> let var_name = ctx_get_var var_id ctx in F.pp_print_string fmt var_name + | CVar var_id -> + let var_name = ctx_get_const_generic_var var_id ctx in + F.pp_print_string fmt var_name | Const cv -> ctx.fmt.extract_literal fmt inside cv | App _ -> let app, args = destruct_apps e in @@ -2279,14 +305,26 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (* Top-level qualifier *) match qualif.id with | FunOrOp fun_id -> - extract_function_call ctx fmt inside fun_id qualif.type_args - qualif.const_generic_args args + extract_function_call ctx fmt inside fun_id qualif.generics args | Global global_id -> extract_global ctx fmt global_id | AdtCons adt_cons_id -> - extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args - qualif.const_generic_args args + extract_adt_cons ctx fmt inside adt_cons_id qualif.generics args | Proj proj -> - extract_field_projector ctx fmt inside app proj qualif.type_args args) + extract_field_projector ctx fmt inside app proj qualif.generics args + | TraitConst (trait_ref, generics, const_name) -> + let use_brackets = generics <> empty_generic_args in + if use_brackets then F.pp_print_string fmt "("; + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref; + extract_generic_args ctx fmt TypeDeclId.Set.empty generics; + let name = + ctx_get_trait_const trait_ref.trait_decl_ref.trait_decl_id + const_name ctx + in + let add_brackets (s : string) = + if !backend = Coq then "(" ^ s ^ ")" else s + in + if use_brackets then F.pp_print_string fmt ")"; + F.pp_print_string fmt ("." ^ add_brackets name)) | _ -> (* "Regular" expression *) (* Open parentheses *) @@ -2309,8 +347,8 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (** Subcase of the app case: function call *) and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (fid : fun_or_op_id) (type_args : ty list) - (cg_args : const_generic list) (args : texpression list) : unit = + (inside : bool) (fid : fun_or_op_id) (generics : generic_args) + (args : texpression list) : unit = match (fid, args) with | Unop unop, [ arg ] -> (* A unop can have *at most* one argument (the result can't be a function!). @@ -2327,24 +365,124 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) if inside then F.pp_print_string fmt "("; (* Open a box for the function call *) F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the function name *) - let with_opaque_pre = ctx.use_opaque_pre in - let fun_name = ctx_get_function with_opaque_pre fun_id ctx in - F.pp_print_string fmt fun_name; - (* Sanity check: HOL4 doesn't support const generics *) - assert (cg_args = [] || !backend <> HOL4); - (* Print the type parameters, if the backend is not HOL4 *) - if !backend <> HOL4 then ( - List.iter - (fun ty -> - F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty true ty) - type_args; - List.iter - (fun cg -> + (* Print the function name. + + For the function name: the id is not the same depending on whether + we call a trait method and a "regular" function (remark: trait + method *implementations* are considered as regular functions here; + only calls to method of traits which are parameterized in a where + clause have a special treatment. + + Remark: the reason why trait method declarations have a special + treatment is that, as traits are extracted to records, we may + allow collisions between trait item names and some other names, + while we do not allow collisions between function names. + + # Impl trait refs: + ================== + When the trait ref refers to an impl, in + [InterpreterStatement.eval_transparent_function_call_symbolic] we + replace the call to the trait impl method to a call to the function + which implements the trait method (that is, we "forget" that we + called a trait method, and treat it as a regular function call). + + # Provided trait methods: + ========================= + Calls to provided trait methods also have a special treatment. + For now, we do not allow overriding provided trait methods (methods + for which a default implementation is provided in the trait declaration). + Whenever we translate a provided trait method, we translate it once as + a function which takes a trait ref as input. We have to handle this + case below. + + With an example, if in Rust we write: + {[ + fn Foo { + fn f(&self) -> u32; // Required + fn ret_true(&self) -> bool { true } // Provided + } + ]} + + We generate: + {[ + structure Foo (Self : Type) = { + f : Self -> result u32 + } + + let ret_true (Self : Type) (self_clause : Foo Self) (self : Self) : result bool = + true + ]} + *) + (match fun_id with + | FromLlbc + (TraitMethod (trait_ref, method_name, _fun_decl_id), lp_id, rg_id) -> + (* We have to check whether the trait method is required or provided *) + let trait_decl_id = trait_ref.trait_decl_ref.trait_decl_id in + let trait_decl = + TraitDeclId.Map.find trait_decl_id ctx.trans_trait_decls + in + let method_id = + PureUtils.trait_decl_get_method trait_decl method_name + in + + if not method_id.is_provided then ( + (* Required method *) + assert (lp_id = None); + extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref; + let fun_name = + ctx_get_trait_method trait_ref.trait_decl_ref.trait_decl_id + method_name rg_id ctx + in + let add_brackets (s : string) = + if !backend = Coq then "(" ^ s ^ ")" else s + in + F.pp_print_string fmt ("." ^ add_brackets fun_name)) + else + (* Provided method: we see it as a regular function call, and use + the function name *) + let fun_id = + FromLlbc (FunId (Regular method_id.id), lp_id, rg_id) + in + let fun_name = ctx_get_function fun_id ctx in + F.pp_print_string fmt fun_name; + + (* Note that we do not need to print the generics for the trait + declaration: they are always implicit as they can be deduced + from the trait self clause. + + Print the trait ref (to instantate the self clause) *) F.pp_print_space fmt (); - extract_const_generic ctx fmt true cg) - cg_args); + extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref + | _ -> + let fun_name = ctx_get_function fun_id ctx in + F.pp_print_string fmt fun_name); + + (* Sanity check: HOL4 doesn't support const generics *) + assert (generics.const_generics = [] || !backend <> HOL4); + (* Print the generics. + + We might need to filter some of the type arguments, if the type + is builtin (for instance, we filter the global allocator type + argument for `Vec::new`). + *) + let types = + match fun_id with + | FromLlbc (FunId (Regular id), _, _) -> + fun_builtin_filter_types id generics.types ctx + | _ -> Result.Ok generics.types + in + (match types with + | Ok types -> + extract_generic_args ctx fmt TypeDeclId.Set.empty + { generics with types } + | Error (types, err) -> + extract_generic_args ctx fmt TypeDeclId.Set.empty + { generics with types }; + if !Config.fail_hard then raise (Failure err) + else + F.pp_print_string fmt + "(\"ERROR: ill-formed builtin: invalid number of filtering \ + arguments\")"); (* Print the arguments *) List.iter (fun ve -> @@ -2366,9 +504,9 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) (** Subcase of the app case: ADT constructor *) and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (adt_cons : adt_cons_id) (type_args : ty list) - (cg_args : const_generic list) (args : texpression list) : unit = - let e_ty = Adt (adt_cons.adt_id, type_args, cg_args) in + (adt_cons : adt_cons_id) (generics : generic_args) (args : texpression list) + : unit = + let e_ty = Adt (adt_cons.adt_id, generics) in let is_single_pat = false in let _ = extract_adt_g_value @@ -2382,7 +520,7 @@ and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (** Subcase of the app case: ADT field projector. *) and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (original_app : texpression) (proj : projection) - (_proj_type_params : ty list) (args : texpression list) : unit = + (_generics : generic_args) (args : texpression list) : unit = (* We isolate the first argument (if there is), in order to pretty print the * projection ([x.field] instead of [MkAdt?.field x] *) match args with @@ -2734,9 +872,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) let extract_as_unit = match (!backend, supd.struct_id) with | HOL4, AdtId adt_id -> - let d = - TypeDeclId.Map.find adt_id ctx.trans_ctx.type_context.type_decls - in + let d = TypeDeclId.Map.find adt_id ctx.trans_ctx.type_ctx.type_decls in d.kind = Struct [] | _ -> false in @@ -2835,17 +971,17 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) F.pp_open_hvbox fmt ctx.indent_incr; let need_paren = inside in if need_paren then F.pp_print_string fmt "("; - (* Open the box for `Array.mk T N [` *) + (* Open the box for `Array.replicate T N [` *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the array constructor *) - let cs = ctx_get_struct false (Assumed Array) ctx in + let cs = ctx_get_struct (Assumed Array) ctx in F.pp_print_string fmt cs; (* Print the parameters *) - let _, tys, cgs = ty_as_adt e_ty in - let ty = Collections.List.to_cons_nil tys in + let _, generics = ty_as_adt e_ty in + let ty = Collections.List.to_cons_nil generics.types in F.pp_print_space fmt (); extract_ty ctx fmt TypeDeclId.Set.empty true ty; - let cg = Collections.List.to_cons_nil cgs in + let cg = Collections.List.to_cons_nil generics.const_generics in F.pp_print_space fmt (); extract_const_generic ctx fmt true cg; F.pp_print_space fmt (); @@ -2872,17 +1008,15 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt () | _ -> raise (Failure "Unreachable") -(** Insert a space, if necessary *) -let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = - if !space then space := false else F.pp_print_space fmt () - (** A small utility to print the parameters of a function signature. We return two contexts: - - the context augmented with bindings for the type parameters - - the context augmented with bindings for the type parameters *and* + - the context augmented with bindings for the generics + - the context augmented with bindings for the generics *and* bindings for the input values + We also return names for the type parameters, const generics, etc. + TODO: do we really need the first one? We should probably always use the second one. It comes from the fact that when we print the input values for the @@ -2890,57 +1024,40 @@ let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = patterns, not the variables). We should figure a cleaner way. *) let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) - (fmt : F.formatter) (def : fun_decl) : extraction_ctx * extraction_ctx = + (fmt : F.formatter) (def : fun_decl) : + extraction_ctx * extraction_ctx * string list = + (* First, add the associated types and constants if the function is a method + in a trait declaration. + + About the order: we want to make sure the names are reserved for + those (variable names might collide with them but it is ok, we will add + suffixes to the variables). + + TODO: micro-pass to update what happens when calling trait provided + functions. + *) + let ctx, trait_decl = + match def.kind with + | TraitMethodProvided (decl_id, _) -> + let trait_decl = T.TraitDeclId.Map.find decl_id ctx.trans_trait_decls in + let ctx, _ = ctx_add_trait_self_clause ctx in + let ctx = { ctx with is_provided_method = true } in + (ctx, Some trait_decl) + | _ -> (ctx, None) + in (* Add the type parameters - note that we need those bindings only for the * body translation (they are not top-level) *) - let ctx, type_params, cg_params = - ctx_add_type_const_generic_params def.signature.type_params - def.signature.const_generic_params ctx + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params def.signature.generics ctx in - (* Print the parameters - rem.: we should have filtered the functions - * with no input parameters *) - (* The type parameters. - - Note that in HOL4 we don't print the type parameters. - *) - if (type_params <> [] || cg_params <> []) && !backend <> HOL4 then ( - (* Open a box for the type and const generic parameters *) - F.pp_open_hovbox fmt 0; - (* The type parameters *) - if type_params <> [] then ( - insert_req_space fmt space; - F.pp_print_string fmt "("; - List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx in - F.pp_print_string fmt pname; - F.pp_print_space fmt ()) - def.signature.type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - let type_keyword = - match !backend with - | FStar -> "Type0" - | Coq | Lean -> "Type" - | HOL4 -> raise (Failure "Unreachable") - in - F.pp_print_string fmt (type_keyword ^ ")")); - (* The const generic parameters *) - if cg_params <> [] then - List.iter - (fun (p : const_generic_var) -> - let pname = ctx_get_const_generic_var p.index ctx in - insert_req_space fmt space; - F.pp_print_string fmt "("; - F.pp_print_string fmt pname; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_literal_type ctx fmt p.ty; - F.pp_print_string fmt ")") - def.signature.const_generic_params; - (* Close the box for the type parameters *) - F.pp_close_box fmt ()); + (* Print the generics *) + (* Open a box for the generics *) + F.pp_open_hovbox fmt 0; + (let space = Some space in + extract_generic_params ctx fmt TypeDeclId.Set.empty ~space ~trait_decl + def.signature.generics type_params cg_params trait_clauses); + (* Close the box for the generics *) + F.pp_close_box fmt (); (* The input parameters - note that doing this adds bindings to the context *) let ctx_body = match def.body with @@ -2963,7 +1080,7 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) ctx) ctx body.inputs_lvs in - (ctx, ctx_body) + (ctx, ctx_body, List.concat [ type_params; cg_params; trait_clauses ]) (** A small utility to print the types of the input parameters in the form: [u32 -> list u32 -> ...] @@ -2982,6 +1099,11 @@ let extract_fun_input_parameters_types (ctx : extraction_ctx) in List.iter extract_param def.signature.inputs +let extract_fun_inputs_output_parameters_types (ctx : extraction_ctx) + (fmt : F.formatter) (def : fun_decl) : unit = + extract_fun_input_parameters_types ctx fmt def; + extract_ty ctx fmt TypeDeclId.Set.empty false def.signature.output + let assert_backend_supports_decreases_clauses () = match !backend with | FStar | Lean -> () @@ -3032,7 +1154,7 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) F.pp_print_space fmt (); (* Extract the parameters *) let space = ref true in - let _, _ = extract_fun_parameters space ctx fmt def in + let _, _, _ = extract_fun_parameters space ctx fmt def in insert_req_space fmt space; F.pp_print_string fmt ":"; (* Print the signature *) @@ -3094,7 +1216,7 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) F.pp_print_space fmt (); (* Extract the parameters *) let space = ref true in - let _, ctx_body = extract_fun_parameters space ctx fmt def in + let _, ctx_body, _ = extract_fun_parameters space ctx fmt def in (* Print the ":=" *) F.pp_print_space fmt (); F.pp_print_string fmt ":="; @@ -3164,7 +1286,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = let { keep_fwd; num_backs } = PureUtils.RegularFunIdMap.find - (A.Regular def.def_id, def.loop_id, def.back_id) + (Pure.FunId (Regular def.def_id), def.loop_id, def.back_id) ctx.fun_name_info in let comment_pre = "[" ^ Print.fun_name_to_string def.basename ^ "]: " in @@ -3205,10 +1327,8 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = assert (not def.is_global_decl_body); (* Retrieve the function name *) - let with_opaque_pre = false in let def_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id def.back_id - ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then @@ -3234,23 +1354,15 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) *) let is_opaque_coq = !backend = Coq && is_opaque in let use_forall = - is_opaque_coq - && (def.signature.type_params <> [] - || def.signature.const_generic_params <> []) + is_opaque_coq && def.signature.generics <> empty_generic_params in - (* Print the qualifier ("assume", etc.). - - if `wrap_opaque_in_sig`: we generate a record of assumed funcions. - TODO: this is obsolete. - *) - (if not (!Config.wrap_opaque_in_sig && (kind = Assumed || kind = Declared)) - then - let qualif = ctx.fmt.fun_decl_kind_to_qualif kind in - match qualif with - | Some qualif -> - F.pp_print_string fmt qualif; - F.pp_print_space fmt () - | None -> ()); + (* Print the qualifier ("assume", etc.). *) + let qualif = ctx.fmt.fun_decl_kind_to_qualif kind in + (match qualif with + | Some qualif -> + F.pp_print_string fmt qualif; + F.pp_print_space fmt () + | None -> ()); F.pp_print_string fmt def_name; F.pp_print_space fmt (); if use_forall then ( @@ -3262,7 +1374,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open a box for "(PARAMS) :" *) F.pp_open_hovbox fmt 0; let space = ref true in - let ctx, ctx_body = extract_fun_parameters space ctx fmt def in + let ctx, ctx_body, all_params = extract_fun_parameters space ctx fmt def in (* Print the return type - note that we have to be careful when * printing the input values for the decrease clause, because * it introduces bindings in the context... We thus "forget" @@ -3310,20 +1422,13 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* The name of the decrease clause *) let decr_name = ctx_get_termination_measure def.def_id def.loop_id ctx in F.pp_print_string fmt decr_name; - (* Print the type/const generic parameters - TODO: we do this many + (* Print the generic parameters - TODO: we do this many times, we should have a helper to factor it out *) List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx in + (fun (name : string) -> F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.type_params; - List.iter - (fun (p : const_generic_var) -> - let pname = ctx_get_const_generic_var p.index ctx in - F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.const_generic_params; + F.pp_print_string fmt name) + all_params; (* Print the input values: we have to be careful here to print * only the input values which are in common with the *forward* * function (the additional input values "given back" to the @@ -3410,19 +1515,12 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for [DECREASES] *) F.pp_open_hovbox fmt ctx.indent_incr; F.pp_print_string fmt terminates_name; - (* Print the type/const generic params - TODO: factor out *) + (* Print the generic params - TODO: factor out *) List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx in + (fun (name : string) -> F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.type_params; - List.iter - (fun (p : const_generic_var) -> - let pname = ctx_get_const_generic_var p.index ctx in - F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.const_generic_params; + F.pp_print_string fmt name) + all_params; (* Print the variables *) List.iter (fun v -> @@ -3475,18 +1573,13 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = (* Retrieve the definition name *) - let with_opaque_pre = false in let def_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id def.back_id - ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in - assert (def.signature.const_generic_params = []); + assert (def.signature.generics.const_generics = []); (* Add the type/const gen parameters - note that we need those bindings only for the generation of the type (they are not top-level) *) - let ctx, _, _ = - ctx_add_type_const_generic_params def.signature.type_params - def.signature.const_generic_params ctx - in + let ctx, _, _, _ = ctx_add_generic_params def.signature.generics ctx in (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0; (* Open a box for the whole definition *) @@ -3635,8 +1728,13 @@ let extract_global_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (* Print the type *) F.pp_open_hovbox fmt 0; extract_ty ctx fmt TypeDeclId.Set.empty false ty; + (* Close the definition *) + F.pp_print_string fmt ")"; + F.pp_close_box fmt (); + (* Close the definition box *) F.pp_close_box fmt (); - (* Close the definition boxe *) F.pp_close_box fmt () + (* Add a line *) + F.pp_print_space fmt () (** Extract a global declaration. @@ -3662,21 +1760,19 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = assert body.is_global_decl_body; assert (Option.is_none body.back_id); - assert (List.length body.signature.inputs = 0); + assert (body.signature.inputs = []); assert (List.length body.signature.doutputs = 1); - assert (List.length body.signature.type_params = 0); - assert (List.length body.signature.const_generic_params = 0); + assert (body.signature.generics = empty_generic_params); (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; extract_comment fmt [ "[" ^ Print.global_name_to_string global.name ^ "]" ]; F.pp_print_space fmt (); - let with_opaque_pre = false in - let decl_name = ctx_get_global with_opaque_pre global.def_id ctx in + let decl_name = ctx_get_global global.def_id ctx in let body_name = - ctx_get_function with_opaque_pre - (FromLlbc (Regular global.body_id, None, None)) + ctx_get_function + (FromLlbc (Pure.FunId (Regular global.body_id), None, None)) ctx in @@ -3713,6 +1809,807 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break to insert lines between declarations *) F.pp_print_break fmt 0 0 +(** Similar to {!extract_trait_decl_register_names} *) +let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) + (trait_decl : trait_decl) + (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : + extraction_ctx = + (* Compute the clause names *) + let clause_names = + match builtin_info with + | None -> + List.map + (fun (c : trait_clause) -> + let name = ctx.fmt.trait_parent_clause_name trait_decl c in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name trait_decl ^ name + in + (c.clause_id, name)) + trait_decl.parent_clauses + | Some info -> + List.map + (fun (c, name) -> (c.clause_id, name)) + (List.combine trait_decl.parent_clauses info.parent_clauses) + in + (* Register the names *) + List.fold_left + (fun ctx (cid, cname) -> + ctx_add (TraitParentClauseId (trait_decl.def_id, cid)) cname ctx) + ctx clause_names + +(** Similar to {!extract_trait_decl_register_names} *) +let extract_trait_decl_register_constant_names (ctx : extraction_ctx) + (trait_decl : trait_decl) + (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : + extraction_ctx = + let consts = trait_decl.consts in + (* Compute the names *) + let constant_names = + match builtin_info with + | None -> + List.map + (fun (item_name, _) -> + let name = ctx.fmt.trait_const_name trait_decl item_name in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name trait_decl ^ name + in + (item_name, name)) + consts + | Some info -> + let const_map = StringMap.of_list info.consts in + List.map + (fun (item_name, _) -> + (item_name, StringMap.find item_name const_map)) + consts + in + (* Register the names *) + List.fold_left + (fun ctx (item_name, name) -> + ctx_add (TraitItemId (trait_decl.def_id, item_name)) name ctx) + ctx constant_names + +(** Similar to {!extract_trait_decl_register_names} *) +let extract_trait_decl_type_names (ctx : extraction_ctx) + (trait_decl : trait_decl) + (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : + extraction_ctx = + let types = trait_decl.types in + (* Compute the names *) + let type_names = + match builtin_info with + | None -> + let compute_type_name (item_name : string) : string = + let type_name = ctx.fmt.trait_type_name trait_decl item_name in + if !Config.record_fields_short_names then type_name + else ctx.fmt.trait_decl_name trait_decl ^ type_name + in + let compute_clause_name (item_name : string) (clause : trait_clause) : + TraitClauseId.id * string = + let name = + ctx.fmt.trait_type_clause_name trait_decl item_name clause + in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name trait_decl ^ name + in + (clause.clause_id, name) + in + List.map + (fun (item_name, (item_clauses, _)) -> + (* Type name *) + let type_name = compute_type_name item_name in + (* Clause names *) + let clauses = + List.map (compute_clause_name item_name) item_clauses + in + (item_name, (type_name, clauses))) + types + | Some info -> + let type_map = StringMap.of_list info.types in + List.map + (fun (item_name, (item_clauses, _)) -> + let type_name, clauses_info = StringMap.find item_name type_map in + let clauses = + List.map + (fun (clause, clause_name) -> (clause.clause_id, clause_name)) + (List.combine item_clauses clauses_info) + in + (item_name, (type_name, clauses))) + types + in + (* Register the names *) + List.fold_left + (fun ctx (item_name, (type_name, clauses)) -> + let ctx = + ctx_add (TraitItemId (trait_decl.def_id, item_name)) type_name ctx + in + List.fold_left + (fun ctx (clause_id, clause_name) -> + ctx_add + (TraitItemClauseId (trait_decl.def_id, item_name, clause_id)) + clause_name ctx) + ctx clauses) + ctx type_names + +(** Similar to {!extract_trait_decl_register_names} *) +let extract_trait_decl_method_names (ctx : extraction_ctx) + (trait_decl : trait_decl) + (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : + extraction_ctx = + let required_methods = trait_decl.required_methods in + (* Compute the names *) + let method_names = + (* We add one field per required forward/backward function *) + let get_funs_for_id (id : fun_decl_id) : fun_decl list = + let trans : pure_fun_translation = FunDeclId.Map.find id ctx.trans_funs in + List.map (fun f -> f.f) (trans.fwd :: trans.backs) + in + match builtin_info with + | None -> + (* We add one field per required forward/backward function *) + let compute_item_names (item_name : string) (id : fun_decl_id) : + string * (RegionGroupId.id option * string) list = + let compute_fun_name (f : fun_decl) : RegionGroupId.id option * string + = + (* We do something special to reuse the [ctx_compute_fun_decl] + function. TODO: make it cleaner. *) + let basename : name = [ Ident item_name ] in + let f = { f with basename } in + let trans = A.FunDeclId.Map.find f.def_id ctx.trans_funs in + let name = ctx_compute_fun_name trans f ctx in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name trait_decl ^ "_" ^ name + in + (f.back_id, name) + in + let funs = get_funs_for_id id in + (item_name, List.map compute_fun_name funs) + in + List.map (fun (name, id) -> compute_item_names name id) required_methods + | Some info -> + let funs_map = StringMap.of_list info.methods in + List.map + (fun (item_name, fun_id) -> + let open ExtractBuiltin in + let info = StringMap.find item_name funs_map in + let trans_funs = get_funs_for_id fun_id in + let find (trans_fun : fun_decl) = + let info = + List.find_opt + (fun (info : builtin_fun_info) -> info.rg = trans_fun.back_id) + info + in + match info with + | Some info -> (info.rg, info.extract_name) + | None -> + let err = + "Ill-formed builtin information for trait decl \"" + ^ Names.name_to_string trait_decl.name + ^ "\", method \"" ^ item_name + ^ "\": could not find name for region " + ^ Print.option_to_string Pure.show_region_group_id + trans_fun.back_id + in + log#serror err; + if !Config.fail_hard then raise (Failure err) + else (trans_fun.back_id, "%ERROR_BUILTIN_NAME_NOT_FOUND%") + in + let rg_with_name_list = List.map find trans_funs in + (item_name, rg_with_name_list)) + required_methods + in + (* Register the names *) + List.fold_left + (fun ctx (item_name, funs) -> + (* We add one field per required forward/backward function *) + List.fold_left + (fun ctx (rg, fun_name) -> + ctx_add + (TraitMethodId (trait_decl.def_id, item_name, rg)) + fun_name ctx) + ctx funs) + ctx method_names + +(** Similar to {!extract_type_decl_register_names} *) +let extract_trait_decl_register_names (ctx : extraction_ctx) + (trait_decl : trait_decl) : extraction_ctx = + (* Lookup the information if this is a builtin trait *) + let open ExtractBuiltin in + let sname = name_to_simple_name trait_decl.name in + let builtin_info = + SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) + in + let ctx = + let trait_name, trait_constructor = + match builtin_info with + | None -> + ( ctx.fmt.trait_decl_name trait_decl, + ctx.fmt.trait_decl_constructor trait_decl ) + | Some info -> (info.extract_name, info.constructor) + in + let ctx = ctx_add (TraitDeclId trait_decl.def_id) trait_name ctx in + ctx_add (TraitDeclConstructorId trait_decl.def_id) trait_constructor ctx + in + (* Parent clauses *) + let ctx = + extract_trait_decl_register_parent_clause_names ctx trait_decl builtin_info + in + (* Constants *) + let ctx = + extract_trait_decl_register_constant_names ctx trait_decl builtin_info + in + (* Types *) + let ctx = extract_trait_decl_type_names ctx trait_decl builtin_info in + (* Required methods *) + let ctx = extract_trait_decl_method_names ctx trait_decl builtin_info in + ctx + +(** Similar to {!extract_type_decl_register_names} *) +let extract_trait_impl_register_names (ctx : extraction_ctx) + (trait_impl : trait_impl) : extraction_ctx = + let decl_id = trait_impl.impl_trait.trait_decl_id in + let trait_decl = TraitDeclId.Map.find decl_id ctx.trans_trait_decls in + (* Check if the trait implementation is builtin *) + let builtin_info = + let open ExtractBuiltin in + let type_sname = name_to_simple_name trait_impl.name in + let trait_sname = name_to_simple_name trait_decl.name in + SimpleNamePairMap.find_opt (type_sname, trait_sname) + (builtin_trait_impls_map ()) + in + (* Register some builtin information (if necessary) *) + let ctx, builtin_info = + match builtin_info with + | None -> (ctx, None) + | Some (filter, info) -> + let ctx = + match filter with + | None -> ctx + | Some filter -> + { + ctx with + trait_impls_filter_type_args_map = + TraitImplId.Map.add trait_impl.def_id filter + ctx.trait_impls_filter_type_args_map; + } + in + (ctx, Some info) + in + + (* For now we do not support overriding provided methods *) + assert (trait_impl.provided_methods = []); + (* Everything is taken care of by {!extract_trait_decl_register_names} *but* + the name of the implementation itself *) + (* Compute the name *) + let name = + match builtin_info with + | None -> ctx.fmt.trait_impl_name trait_decl trait_impl + | Some name -> name + in + ctx_add (TraitImplId trait_impl.def_id) name ctx + +(** Small helper. + + The type `ty` is to be understood in a very general sense. + *) +let extract_trait_item (ctx : extraction_ctx) (fmt : F.formatter) + (item_name : string) (separator : string) (ty : unit -> unit) : unit = + F.pp_print_space fmt (); + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_string fmt item_name; + F.pp_print_space fmt (); + (* ":" or "=" *) + F.pp_print_string fmt separator; + ty (); + (match !Config.backend with Lean -> () | _ -> F.pp_print_string fmt ";"); + F.pp_close_box fmt () + +let extract_trait_decl_item (ctx : extraction_ctx) (fmt : F.formatter) + (item_name : string) (ty : unit -> unit) : unit = + extract_trait_item ctx fmt item_name ":" ty + +let extract_trait_impl_item (ctx : extraction_ctx) (fmt : F.formatter) + (item_name : string) (ty : unit -> unit) : unit = + let assign = match !Config.backend with Lean | Coq -> ":=" | _ -> "=" in + extract_trait_item ctx fmt item_name assign ty + +(** Small helper - TODO: move *) +let generic_params_drop_prefix ~(drop_trait_clauses : bool) + (g1 : generic_params) (g2 : generic_params) : generic_params = + let open Collections.List in + let types = drop (length g1.types) g2.types in + let const_generics = drop (length g1.const_generics) g2.const_generics in + let trait_clauses = + if drop_trait_clauses then drop (length g1.trait_clauses) g2.trait_clauses + else g2.trait_clauses + in + { types; const_generics; trait_clauses } + +(** Small helper. + + Extract the items for a method in a trait decl. + *) +let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) + (decl : trait_decl) (item_name : string) (id : fun_decl_id) : unit = + (* Lookup the definition *) + let trans = A.FunDeclId.Map.find id ctx.trans_funs in + (* Extract the items *) + let funs = if trans.keep_fwd then trans.fwd :: trans.backs else trans.backs in + let extract_method (f : fun_and_loops) = + let f = f.f in + let fun_name = ctx_get_trait_method decl.def_id item_name f.back_id ctx in + let ty () = + (* Extract the generics *) + (* We need to add the generics specific to the method, by removing those + which actually apply to the trait decl *) + let generics = + let drop_trait_clauses = false in + generic_params_drop_prefix ~drop_trait_clauses decl.generics + f.signature.generics + in + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params generics ctx + in + let backend_uses_forall = + match !backend with Coq | Lean -> true | FStar | HOL4 -> false + in + let generics_not_empty = generics <> empty_generic_params in + let use_forall = generics_not_empty && backend_uses_forall in + let use_arrows = generics_not_empty && not backend_uses_forall in + let use_forall_use_sep = false in + extract_generic_params ctx fmt TypeDeclId.Set.empty ~use_forall + ~use_forall_use_sep ~use_arrows generics type_params cg_params + trait_clauses; + if use_forall then F.pp_print_string fmt ","; + (* Extract the inputs and output *) + F.pp_print_space fmt (); + extract_fun_inputs_output_parameters_types ctx fmt f + in + extract_trait_decl_item ctx fmt fun_name ty + in + List.iter extract_method funs + +(** Extract a trait declaration *) +let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) + (decl : trait_decl) : unit = + (* Retrieve the trait name *) + let decl_name = ctx_get_trait_decl decl.def_id ctx in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + extract_comment fmt + [ "Trait declaration: [" ^ Print.name_to_string decl.name ^ "]" ]; + F.pp_print_break fmt 0 0; + (* Open two outer boxes for the definition, so that whenever possible it gets printed on + one line and indents are correct. + + There is just an exception with Lean: in this backend, line breaks are important + for the parsing, so we always open a vertical box. + *) + if !Config.backend = Lean then F.pp_open_vbox fmt ctx.indent_incr + else ( + F.pp_open_hvbox fmt 0; + F.pp_open_hvbox fmt ctx.indent_incr); + + (* `struct Trait (....) =` *) + (* Open the box for the name + generics *) + F.pp_open_hovbox fmt ctx.indent_incr; + let qualif = + Option.get (ctx.fmt.type_decl_kind_to_qualif SingleNonRec (Some Struct)) + in + (* When checking if the trait declaration is empty: we ignore the provided + methods, because for now they are extracted separately *) + let is_empty = trait_decl_is_empty { decl with provided_methods = [] } in + if !backend = FStar && not is_empty then ( + F.pp_print_string fmt "noeq"; + F.pp_print_space fmt ()); + F.pp_print_string fmt qualif; + F.pp_print_space fmt (); + F.pp_print_string fmt decl_name; + (* Print the generics *) + let generics = decl.generics in + (* Add the type and const generic params - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params generics ctx + in + extract_generic_params ctx fmt TypeDeclId.Set.empty generics type_params + cg_params trait_clauses; + + F.pp_print_space fmt (); + if is_empty && !backend = FStar then ( + F.pp_print_string fmt "= unit"; + (* Outer box *) + F.pp_close_box fmt ()) + else if is_empty && !backend = Coq then ( + (* Coq is not very good at infering constructors *) + let cons = ctx_get_trait_constructor decl.def_id ctx in + F.pp_print_string fmt (":= " ^ cons ^ "{}."); + (* Outer box *) + F.pp_close_box fmt ()) + else ( + (match !backend with + | Lean -> F.pp_print_string fmt "where" + | FStar -> F.pp_print_string fmt "= {" + | Coq -> + let cons = ctx_get_trait_constructor decl.def_id ctx in + F.pp_print_string fmt (":= " ^ cons ^ " {") + | _ -> F.pp_print_string fmt "{"); + + (* Close the box for the name + generics *) + F.pp_close_box fmt (); + + (* + * Extract the items + *) + + (* The constants *) + List.iter + (fun (name, (ty, _)) -> + let item_name = ctx_get_trait_const decl.def_id name ctx in + let ty () = + let inside = false in + F.pp_print_space fmt (); + extract_ty ctx fmt TypeDeclId.Set.empty inside ty + in + extract_trait_decl_item ctx fmt item_name ty) + decl.consts; + + (* The types *) + List.iter + (fun (name, (clauses, _)) -> + (* Extract the type *) + let item_name = ctx_get_trait_type decl.def_id name ctx in + let ty () = + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ()) + in + extract_trait_decl_item ctx fmt item_name ty; + (* Extract the clauses *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + in + extract_trait_decl_item ctx fmt item_name ty) + clauses) + decl.types; + + (* The parent clauses - note that the parent clauses may refer to the types + and const generics: for this reason we extract them *after* *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + in + extract_trait_decl_item ctx fmt item_name ty) + decl.parent_clauses; + + (* The required methods *) + List.iter + (fun (name, id) -> extract_trait_decl_method_items ctx fmt decl name id) + decl.required_methods; + + (* Close the outer boxes for the definition *) + if !Config.backend <> Lean then F.pp_close_box fmt (); + (* Close the brackets *) + match !Config.backend with + | Lean -> () + | Coq -> + F.pp_print_space fmt (); + F.pp_print_string fmt "}." + | _ -> + F.pp_print_space fmt (); + F.pp_print_string fmt "}"); + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Generate the [Arguments] instructions for the trait declarationsin Coq, so + that we don't have to provide the implicit arguments when projecting the fields. *) +let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) + (decl : trait_decl) : unit = + (* Generating the [Arguments] instructions is useful only if there are parameters *) + let num_params = + List.length decl.generics.types + + List.length decl.generics.const_generics + + List.length decl.generics.trait_clauses + in + if num_params > 0 then ( + (* The constructor *) + let cons_name = ctx_get_trait_constructor decl.def_id ctx in + extract_coq_arguments_instruction ctx fmt cons_name num_params; + (* The constants *) + List.iter + (fun (name, _) -> + let item_name = ctx_get_trait_const decl.def_id name ctx in + extract_coq_arguments_instruction ctx fmt item_name num_params) + decl.consts; + (* The types *) + List.iter + (fun (name, (clauses, _)) -> + (* The type *) + let item_name = ctx_get_trait_type decl.def_id name ctx in + extract_coq_arguments_instruction ctx fmt item_name num_params; + (* The type clauses *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx + in + extract_coq_arguments_instruction ctx fmt item_name num_params) + clauses) + decl.types; + (* The parent clauses *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + in + extract_coq_arguments_instruction ctx fmt item_name num_params) + decl.parent_clauses; + (* The required methods *) + List.iter + (fun (item_name, id) -> + (* Lookup the definition *) + let trans = A.FunDeclId.Map.find id ctx.trans_funs in + (* Extract the items *) + let funs = + if trans.keep_fwd then trans.fwd :: trans.backs else trans.backs + in + let extract_for_method (f : fun_and_loops) = + let f = f.f in + let item_name = + ctx_get_trait_method decl.def_id item_name f.back_id ctx + in + extract_coq_arguments_instruction ctx fmt item_name num_params + in + List.iter extract_for_method funs) + decl.required_methods; + (* Add a space *) + F.pp_print_space fmt ()) + +(** See {!extract_trait_decl_coq_arguments} *) +let extract_trait_decl_extra_info (ctx : extraction_ctx) (fmt : F.formatter) + (trait_decl : trait_decl) : unit = + match !backend with + | Coq -> extract_trait_decl_coq_arguments ctx fmt trait_decl + | _ -> () + +(** Small helper. + + Extract the items for a method in a trait impl. + *) +let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) + (impl : trait_impl) (item_name : string) (id : fun_decl_id) + (impl_generics : string list * string list * string list) : unit = + let trait_decl_id = impl.impl_trait.trait_decl_id in + (* Lookup the definition *) + let trans = A.FunDeclId.Map.find id ctx.trans_funs in + (* Extract the items *) + let funs = if trans.keep_fwd then trans.fwd :: trans.backs else trans.backs in + let extract_method (f : fun_and_loops) = + let f = f.f in + let fun_name = ctx_get_trait_method trait_decl_id item_name f.back_id ctx in + let ty () = + (* Filter the generics if the method is a builtin *) + let i_tys, _, _ = impl_generics in + let impl_types, i_tys, f_tys = + match FunDeclId.Map.find_opt f.def_id ctx.funs_filter_type_args_map with + | None -> (impl.generics.types, i_tys, f.signature.generics.types) + | Some filter -> + let filter_list filter ls = + let ls = List.combine filter ls in + List.filter_map (fun (b, ty) -> if b then Some ty else None) ls + in + let impl_types = impl.generics.types in + let impl_filter = + Collections.List.prefix (List.length impl_types) filter + in + let i_tys = i_tys in + let i_filter = Collections.List.prefix (List.length i_tys) filter in + ( filter_list impl_filter impl_types, + filter_list i_filter i_tys, + filter_list filter f.signature.generics.types ) + in + let f_generics = { f.signature.generics with types = f_tys } in + (* Extract the generics - we need to quantify over the generics which + are specific to the method, and call it will all the generics + (trait impl + method generics) *) + let f_generics = + let drop_trait_clauses = true in + generic_params_drop_prefix ~drop_trait_clauses + { impl.generics with types = impl_types } + f_generics + in + (* Register and print the quantified generics *) + let ctx, f_tys, f_cgs, f_tcs = ctx_add_generic_params f_generics ctx in + let use_forall = f_generics <> empty_generic_params in + extract_generic_params ctx fmt TypeDeclId.Set.empty ~use_forall f_generics + f_tys f_cgs f_tcs; + if use_forall then F.pp_print_string fmt ","; + (* Extract the function call *) + F.pp_print_space fmt (); + let fun_name = ctx_get_local_function f.def_id None f.back_id ctx in + F.pp_print_string fmt fun_name; + let all_generics = + let _, i_cgs, i_tcs = impl_generics in + List.concat [ i_tys; f_tys; i_cgs; f_cgs; i_tcs; f_tcs ] + in + + (* Filter the generics if the function is builtin *) + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + all_generics + in + extract_trait_impl_item ctx fmt fun_name ty + in + List.iter extract_method funs + +(** Extract a trait implementation *) +let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) + (impl : trait_impl) : unit = + log#ldebug (lazy ("extract_trait_impl: " ^ Names.name_to_string impl.name)); + (* Retrieve the impl name *) + let impl_name = ctx_get_trait_impl impl.def_id ctx in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + extract_comment fmt + [ "Trait implementation: [" ^ Print.name_to_string impl.name ^ "]" ]; + F.pp_print_break fmt 0 0; + + (* Open two outer boxes for the definition, so that whenever possible it gets printed on + one line and indents are correct. + + There is just an exception with Lean: in this backend, line breaks are important + for the parsing, so we always open a vertical box. + *) + if !Config.backend = Lean then ( + F.pp_open_vbox fmt 0; + F.pp_open_vbox fmt ctx.indent_incr) + else ( + F.pp_open_hvbox fmt 0; + F.pp_open_hvbox fmt ctx.indent_incr); + + (* `let (....) : Trait ... =` *) + (* Open the box for the name + generics *) + F.pp_open_hovbox fmt ctx.indent_incr; + (match ctx.fmt.fun_decl_kind_to_qualif SingleNonRec with + | Some qualif -> + F.pp_print_string fmt qualif; + F.pp_print_space fmt () + | None -> ()); + F.pp_print_string fmt impl_name; + + (* Print the generics *) + (* Add the type and const generic params - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params impl.generics ctx + in + let all_generics = (type_params, cg_params, trait_clauses) in + extract_generic_params ctx fmt TypeDeclId.Set.empty impl.generics type_params + cg_params trait_clauses; + + (* Print the type *) + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_trait_decl_ref ctx fmt TypeDeclId.Set.empty false impl.impl_trait; + + (* When checking if the trait impl is empty: we ignore the provided + methods, because for now they are extracted separately *) + let is_empty = trait_impl_is_empty { impl with provided_methods = [] } in + + F.pp_print_space fmt (); + if is_empty && !Config.backend = FStar then ( + F.pp_print_string fmt "= ()"; + (* Outer box *) + F.pp_close_box fmt ()) + else if is_empty && !Config.backend = Coq then ( + (* Coq is not very good at infering constructors *) + let cons = ctx_get_trait_constructor impl.impl_trait.trait_decl_id ctx in + F.pp_print_string fmt (":= " ^ cons ^ "."); + (* Outer box *) + F.pp_close_box fmt ()) + else ( + if !Config.backend = Lean then F.pp_print_string fmt ":= {" + else if !Config.backend = Coq then F.pp_print_string fmt ":= {|" + else F.pp_print_string fmt "= {"; + + (* Close the box for the name + generics *) + F.pp_close_box fmt (); + + (* + * Extract the items + *) + let trait_decl_id = impl.impl_trait.trait_decl_id in + + (* The constants *) + List.iter + (fun (name, (_, id)) -> + let item_name = ctx_get_trait_const trait_decl_id name ctx in + let ty () = + F.pp_print_space fmt (); + F.pp_print_string fmt (ctx_get_global id ctx) + in + + extract_trait_impl_item ctx fmt item_name ty) + impl.consts; + + (* The types *) + List.iter + (fun (name, (trait_refs, ty)) -> + (* Extract the type *) + let item_name = ctx_get_trait_type trait_decl_id name ctx in + let ty () = + F.pp_print_space fmt (); + extract_ty ctx fmt TypeDeclId.Set.empty false ty + in + extract_trait_impl_item ctx fmt item_name ty; + (* Extract the clauses *) + TraitClauseId.iteri + (fun clause_id trait_ref -> + let item_name = + ctx_get_trait_item_clause trait_decl_id name clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + in + extract_trait_impl_item ctx fmt item_name ty) + trait_refs) + impl.types; + + (* The parent clauses *) + TraitClauseId.iteri + (fun clause_id trait_ref -> + let item_name = + ctx_get_trait_parent_clause trait_decl_id clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + in + extract_trait_impl_item ctx fmt item_name ty) + impl.parent_trait_refs; + + (* The required methods *) + List.iter + (fun (name, id) -> + extract_trait_impl_method_items ctx fmt impl name id all_generics) + impl.required_methods; + + (* Close the outer boxes for the definition, as well as the brackets *) + F.pp_close_box fmt (); + if !backend = Coq then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "|}.") + else if (not (!backend = FStar)) || not is_empty then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "}")); + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + (** Extract a unit test, if the function is a unit function (takes no parameters, returns unit). @@ -3735,8 +2632,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) (* Check if this is a unit function *) let sg = def.signature in if - sg.type_params = [] - && sg.const_generic_params = [] + sg.generics = empty_generic_params && (sg.inputs = [ mk_unit_ty ] || sg.inputs = []) && sg.output = mk_result_ty mk_unit_ty then ( @@ -3756,12 +2652,8 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "assert_norm"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - (* Note that if the function is opaque, the unit test will fail - because the normalizer will get stuck *) - let with_opaque_pre = ctx.use_opaque_pre in let fun_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( @@ -3776,12 +2668,8 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "Check"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - (* Note that if the function is opaque, the unit test will fail - because the normalizer will get stuck *) - let with_opaque_pre = ctx.use_opaque_pre in let fun_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( @@ -3793,12 +2681,8 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "#assert"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - (* Note that if the function is opaque, the unit test will fail - because the normalizer will get stuck *) - let with_opaque_pre = ctx.use_opaque_pre in let fun_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( @@ -3812,12 +2696,8 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; F.pp_print_string fmt "“"; - (* Note that if the function is opaque, the unit test will fail - because the normalizer will get stuck *) - let with_opaque_pre = ctx.use_opaque_pre in let fun_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index d733c763..31b1a447 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -5,9 +5,10 @@ open TranslateCore module C = Contexts module RegionVarId = T.RegionVarId module F = Format +open ExtractBuiltin (** The local logger *) -let log = L.pure_to_extract_log +let log = L.extract_log type region_group_info = { id : RegionGroupId.id; @@ -21,8 +22,8 @@ type region_group_info = { *) } -module StringSet = Collections.MakeSet (Collections.OrderedString) -module StringMap = Collections.MakeMap (Collections.OrderedString) +module StringSet = Collections.StringSet +module StringMap = Collections.StringMap type name = Names.name type type_name = Names.type_name @@ -77,6 +78,7 @@ type decl_kind = F*: [val x : Type0] Coq: [Axiom x : Type.] *) +[@@deriving show] (** Return [true] if the declaration is the last from its group of declarations. @@ -111,9 +113,9 @@ let decl_is_first_from_group (kind : decl_kind) : bool = let decl_is_not_last_from_group (kind : decl_kind) : bool = not (decl_is_last_from_group kind) -(* TODO: this should a module we give to a functor! *) +type type_decl_kind = Enum | Struct [@@deriving show] -type type_decl_kind = Enum | Struct +(* TODO: this should be a module we give to a functor! *) (** A formatter's role is twofold: 1. Come up with name suggestions. @@ -125,6 +127,9 @@ type type_decl_kind = Enum | Struct snake case, adding prefixes/suffixes, etc. 2. Format some specific terms, like constants. + + TODO: unclear that this is useful now that all the backends are so much + entangled in Extract.ml *) type formatter = { bool_name : string; @@ -239,37 +244,14 @@ type formatter = { the same purpose as in {!field:fun_name}. - loop identifier, if this is for a loop *) - opaque_pre : unit -> string; - (** TODO: obsolete, remove. - - The prefix to use for opaque definitions. - - We need this because for some backends like Lean and Coq, we group - opaque definitions in module signatures, meaning that using those - definitions requires to prefix them with a module parameter name (such - as "opaque_defs."). - - For instance, if we have an opaque function [f : int -> int], which - is used by the non-opaque function [g], we would generate (in Coq): - {[ - (* The module signature declaring the opaque definitions *) - module type OpaqueDefs = { - f_fwd : int -> int - ... (* Other definitions *) - } - - (* The definitions generated for the non-opaque definitions *) - module Funs (opaque: OpaqueDefs) = { - let g ... = - ... - opaque_defs.f_fwd - ... - } - ]} - - Upon using [f] in [g], we don't directly use the the name "f_fwd", - but prefix it with the "opaque_defs." identifier. - *) + trait_decl_name : trait_decl -> string; + trait_impl_name : trait_decl -> trait_impl -> string; + trait_decl_constructor : trait_decl -> string; + trait_parent_clause_name : trait_decl -> trait_clause -> string; + trait_const_name : trait_decl -> string -> string; + trait_type_name : trait_decl -> string -> string; + trait_method_name : trait_decl -> string -> string; + trait_type_clause_name : trait_decl -> string -> trait_clause -> string; var_basename : StringSet.t -> string option -> ty -> string; (** Generates a variable basename. @@ -288,6 +270,14 @@ type formatter = { (** Generates a type variable basename. *) const_generic_var_basename : StringSet.t -> string -> string; (** Generates a const generic variable basename. *) + trait_self_clause_basename : string; + trait_clause_basename : StringSet.t -> trait_clause -> string; + (** Return a base name for a trait clause. We might add a suffix to prevent + collisions. + + In the traduction we explicitely manipulate the trait clause instances, + that is we introduce one input variable for each trait clause. + *) append_index : string -> int -> string; (** Appends an index to a name - we use this to generate unique names: when doing so, the role of the formatter is just to concatenate @@ -396,10 +386,60 @@ type id = | TypeVarId of TypeVarId.id | ConstGenericVarId of ConstGenericVarId.id | VarId of VarId.id + | TraitDeclId of TraitDeclId.id + | TraitImplId of TraitImplId.id + | LocalTraitClauseId of TraitClauseId.id + | TraitDeclConstructorId of TraitDeclId.id + | TraitMethodId of TraitDeclId.id * string * T.RegionGroupId.id option + (** Something peculiar with trait methods: because we have to take into + account forward/backward functions, we may need to generate fields + items per method. + *) + | TraitItemId of TraitDeclId.id * string + (** A trait associated item which is not a method *) + | TraitParentClauseId of TraitDeclId.id * TraitClauseId.id + | TraitItemClauseId of TraitDeclId.id * string * TraitClauseId.id + | TraitSelfClauseId + (** Specifically for the clause: [Self : Trait]. + + For now, we forbid provided methods (methods in trait declarations + with a default implementation) from being overriden in trait implementations. + We extract trait provided methods such that they take an instance of + the trait as input: this instance is given by the trait self clause. + + For instance: + {[ + // + // Rust + // + trait ToU64 { + fn to_u64(&self) -> u64; + + // Provided method + fn is_pos(&self) -> bool { + self.to_u64() > 0 + } + } + + // + // Generated code + // + struct ToU64 (T : Type) { + to_u64 : T -> u64; + } + + // The trait self clause + // vvvvvvvvvvvvvvvvvvvvvv + let is_pos (T : Type) (trait_self : ToU64 T) (self : T) : bool = + trait_self.to_u64 self > 0 + ]} + *) | UnknownId (** Used for stored various strings like keywords, definitions which should always be in context, etc. and which can't be linked to one of the above. + + TODO: rename to "keyword" *) [@@deriving show, ord] @@ -429,69 +469,64 @@ type names_map = { precisely which identifiers are mapped to the same name... *) names_set : StringSet.t; - opaque_ids : IdSet.t; - (** TODO: this is obsolete. Remove. +} - The set of opaque definitions. +let empty_names_map : names_map = + { + id_to_name = IdMap.empty; + name_to_id = StringMap.empty; + names_set = StringSet.empty; + } - See {!formatter.opaque_pre} for detailed explanations about why - we need to know which definitions are opaque to compute names. +(** Small helper to report name collision *) +let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) + (name : string) : unit = + let id1 = "\n- " ^ id_to_string id1 in + let id2 = "\n- " ^ id_to_string id2 in + let err = + "Name clash detected: the following identifiers are bound to the same name \ + \"" ^ name ^ "\":" ^ id1 ^ id2 + ^ "\nYou may want to rename some of your definitions, or report an issue." + in + log#serror err; + (* If we fail hard on errors, raise an exception *) + if !Config.fail_hard then raise (Failure err) - Also note that the opaque ids don't contain the ids of the assumed - definitions. In practice, assumed definitions are opaque_defs. However, they - are not grouped in the opaque module, meaning we never need to - prefix them (with, say, "opaque_defs."): we thus consider them as non-opaque - with regards to the names map. - *) -} +let names_map_get_id_from_name (name : string) (nm : names_map) : id option = + StringMap.find_opt name nm.name_to_id -let names_map_add (id_to_string : id -> string) (is_opaque : bool) (id : id) - (name : string) (nm : names_map) : names_map = - (* Check if there is a clash *) - (match StringMap.find_opt name nm.name_to_id with +let names_map_check_collision (id_to_string : id -> string) (id : id) + (name : string) (nm : names_map) : unit = + match names_map_get_id_from_name name nm with | None -> () (* Ok *) | Some clash -> (* There is a clash: print a nice debugging message for the user *) - let id1 = "\n- " ^ id_to_string clash in - let id2 = "\n- " ^ id_to_string id in - let err = - "Name clash detected: the following identifiers are bound to the same \ - name \"" ^ name ^ "\":" ^ id1 ^ id2 - in - log#serror err; - raise (Failure err)); - (* Sanity check *) - assert (not (StringSet.mem name nm.names_set)); + report_name_collision id_to_string clash id name + +(** Insert bindings in a names map without checking for collisions *) +let names_map_add_unchecked (id : id) (name : string) (nm : names_map) : + names_map = (* Insert *) let id_to_name = IdMap.add id name nm.id_to_name in let name_to_id = StringMap.add name id nm.name_to_id in let names_set = StringSet.add name nm.names_set in - let opaque_ids = - if is_opaque then IdSet.add id nm.opaque_ids else nm.opaque_ids - in - { id_to_name; name_to_id; names_set; opaque_ids } - -let names_map_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) - (name : string) (nm : names_map) : names_map = - let is_opaque = false in - names_map_add id_to_string is_opaque (TypeId (Assumed id)) name nm - -let names_map_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) - (name : string) (nm : names_map) : names_map = - let is_opaque = false in - names_map_add id_to_string is_opaque (StructId (Assumed id)) name nm + { id_to_name; name_to_id; names_set } -let names_map_add_assumed_variant (id_to_string : id -> string) - (id : assumed_ty) (variant_id : VariantId.id) (name : string) +let names_map_add (id_to_string : id -> string) (id : id) (name : string) (nm : names_map) : names_map = - let is_opaque = false in - names_map_add id_to_string is_opaque - (VariantId (Assumed id, variant_id)) - name nm - -let names_map_add_function (id_to_string : id -> string) (is_opaque : bool) - (fid : fun_id) (name : string) (nm : names_map) : names_map = - names_map_add id_to_string is_opaque (FunId fid) name nm + (* Check if there is a clash *) + names_map_check_collision id_to_string id name nm; + (* Sanity check *) + if StringSet.mem name nm.names_set then ( + let err = + "Error when registering the name for id: " ^ id_to_string id + ^ ":\nThe chosen name is already in the names set: " ^ name + in + log#serror err; + (* If we fail hard on errors, raise an exception *) + if !Config.fail_hard then raise (Failure err)); + (* Insert *) + names_map_add_unchecked id name nm (** The unsafe names map stores mappings from identifiers to names which might collide. For some backends and some names, it might be acceptable to have @@ -503,6 +538,8 @@ let names_map_add_function (id_to_string : id -> string) (is_opaque : bool) *) type unsafe_names_map = { id_to_name : string IdMap.t } +let empty_unsafe_names_map = { id_to_name = IdMap.empty } + let unsafe_names_map_add (id : id) (name : string) (nm : unsafe_names_map) : unsafe_names_map = { id_to_name = IdMap.add id name nm.id_to_name } @@ -541,6 +578,24 @@ let basename_to_unique (names_set : StringSet.t) type fun_name_info = { keep_fwd : bool; num_backs : int } +type names_maps = { + names_map : names_map; + (** The map for id to names, where we forbid name collisions + (ex.: we always forbid function name collisions). *) + unsafe_names_map : unsafe_names_map; + (** The map for id to names, where we allow name collisions + (ex.: we might allow record field name collisions). *) + strict_names_map : names_map; + (** This map is a sub-map of [names_map]. For the ids in this map we also + forbid collisions with names in the [unsafe_names_map]. + + We do so for keywords for instance, but also for types (in a dependently + typed language, we might have an issue if the field of a record has, say, + the name "u32", and another field of the same record refers to "u32" + (for instance in its type). + *) +} + (** Extraction context. Note that the extraction context contains information coming from the @@ -549,24 +604,12 @@ type fun_name_info = { keep_fwd : bool; num_backs : int } functions, etc. *) type extraction_ctx = { + crate : A.crate; trans_ctx : trans_ctx; - names_map : names_map; - (** The map for id to names, where we forbid name collisions - (ex.: we always forbid function name collisions). *) - unsafe_names_map : unsafe_names_map; - (** The map for id to names, where we allow name collisions - (ex.: we might allow record field name collisions). *) + names_maps : names_maps; fmt : formatter; indent_incr : int; (** The indent increment we insert whenever we need to indent more *) - use_opaque_pre : bool; - (** Do we use the "opaque_defs." prefix for the opaque definitions? - - Opaque function definitions might refer opaque types: if we are in the - opaque module, we musn't use the "opaque_defs." prefix, otherwise we - use it. - Also see {!names_map.opaque_ids}. - *) use_dep_ite : bool; (** For Lean: do we use dependent-if then else expressions? @@ -586,6 +629,29 @@ type extraction_ctx = { in case a Rust function only has one backward translation and we filter the forward function because it returns unit. *) + trait_decl_id : trait_decl_id option; + (** If we are extracting a trait declaration, identifies it *) + is_provided_method : bool; + trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; + trans_funs : pure_fun_translation A.FunDeclId.Map.t; + functions_with_decreases_clause : PureUtils.FunLoopIdSet.t; + trans_trait_decls : Pure.trait_decl Pure.TraitDeclId.Map.t; + trans_trait_impls : Pure.trait_impl Pure.TraitImplId.Map.t; + types_filter_type_args_map : bool list TypeDeclId.Map.t; + (** The map to filter the type arguments for the builtin type + definitions. + + We need this for type `Vec`, for instance, which takes a useless + (in the context of the type translation) type argument for the + allocator which is used, and which we want to remove. + + TODO: it would be cleaner to filter those types in a micro-pass, + rather than at code generation time. + *) + funs_filter_type_args_map : bool list FunDeclId.Map.t; + (** Same as {!types_filter_type_args_map}, but for functions *) + trait_impls_filter_type_args_map : bool list TraitImplId.Map.t; + (** Same as {!types_filter_type_args_map}, but for trait implementations *) } (** Debugging function, used when communicating name collisions to the user, @@ -593,9 +659,16 @@ type extraction_ctx = { instance). *) let id_to_string (id : id) (ctx : extraction_ctx) : string = - let global_decls = ctx.trans_ctx.global_context.global_decls in - let fun_decls = ctx.trans_ctx.fun_context.fun_decls in - let type_decls = ctx.trans_ctx.type_context.type_decls in + let global_decls = ctx.trans_ctx.global_ctx.global_decls in + let fun_decls = ctx.trans_ctx.fun_ctx.fun_decls in + let type_decls = ctx.trans_ctx.type_ctx.type_decls in + let trait_decls = ctx.trans_ctx.trait_decls_ctx.trait_decls in + let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = + let trait_name = + Print.fun_name_to_string (A.TraitDeclId.Map.find id trait_decls).name + in + "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" + in (* TODO: factorize the pretty-printing with what is in PrintPure *) let get_type_name (id : type_id) : string = match id with @@ -614,10 +687,17 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | FromLlbc (fid, lp_id, rg_id) -> let fun_name = match fid with - | Regular fid -> + | FunId (Regular fid) -> Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | Assumed aid -> A.show_assumed_fun_id aid + | FunId (Assumed aid) -> A.show_assumed_fun_id aid + | TraitMethod (trait_ref, method_name, _) -> + (* Shouldn't happen *) + if !Config.fail_hard then raise (Failure "Unexpected") + else + "Trait method: decl: " + ^ TraitDeclId.to_string trait_ref.trait_decl_ref.trait_decl_id + ^ ", method_name: " ^ method_name in let lp_kind = @@ -673,12 +753,16 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = if variant_id = error_failure_id then "@error::Failure" else if variant_id = error_out_of_fuel_id then "@error::OutOfFuel" else raise (Failure "Unreachable") - | Assumed Option -> - if variant_id = option_some_id then "@option::Some" - else if variant_id = option_none_id then "@option::None" + | Assumed Fuel -> + if variant_id = fuel_zero_id then "@fuel::0" + else if variant_id = fuel_succ_id then "@fuel::Succ" else raise (Failure "Unreachable") - | Assumed (State | Vec | Fuel | Array | Slice | Str | Range) -> - raise (Failure "Unreachable") + | Assumed (State | Array | Slice | Str | RawPtr _) -> + raise + (Failure + ("Unreachable: variant id (" + ^ VariantId.to_string variant_id + ^ ") for " ^ show_type_id id)) | AdtId id -> ( let def = TypeDeclId.Map.find id type_decls in match def.kind with @@ -693,8 +777,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = match id with | Tuple -> raise (Failure "Unreachable") | Assumed - ( State | Result | Error | Fuel | Option | Vec | Array | Slice | Str - | Range ) -> + (State | Result | Error | Fuel | Array | Slice | Str | RawPtr _) -> (* We can't directly have access to the fields of those types *) raise (Failure "Unreachable") | AdtId id -> ( @@ -716,134 +799,265 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | ConstGenericVarId id -> "const_generic_var_id: " ^ ConstGenericVarId.to_string id | VarId id -> "var_id: " ^ VarId.to_string id + | TraitDeclId id -> "trait_decl_id: " ^ TraitDeclId.to_string id + | TraitImplId id -> "trait_impl_id: " ^ TraitImplId.to_string id + | LocalTraitClauseId id -> + "local_trait_clause_id: " ^ TraitClauseId.to_string id + | TraitDeclConstructorId id -> + "trait_decl_constructor: " ^ trait_decl_id_to_string id + | TraitParentClauseId (id, clause_id) -> + "trait_parent_clause_id: " ^ trait_decl_id_to_string id ^ ", clause_id: " + ^ TraitClauseId.to_string clause_id + | TraitItemClauseId (id, item_name, clause_id) -> + "trait_item_clause_id: " ^ trait_decl_id_to_string id ^ ", item name: " + ^ item_name ^ ", clause_id: " + ^ TraitClauseId.to_string clause_id + | TraitItemId (id, name) -> + "trait_item_id: " ^ trait_decl_id_to_string id ^ ", type name: " ^ name + | TraitMethodId (trait_decl_id, fun_name, rg_id) -> + let fwd_back_kind = + match rg_id with + | None -> "forward" + | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id + in + trait_decl_id_to_string trait_decl_id + ^ ", method name (" ^ fwd_back_kind ^ "): " ^ fun_name + | TraitSelfClauseId -> "trait_self_clause" + +(** Return [true] if we are strict on collisions for this id (i.e., we forbid + collisions even with the ids in the unsafe names map) *) +let strict_collisions (id : id) : bool = + match id with UnknownId | TypeId _ -> true | _ -> false (** We might not check for collisions for some specific ids (ex.: field names) *) let allow_collisions (id : id) : bool = match id with - | FieldId (_, _) -> !Config.record_fields_short_names + | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ + | TraitMethodId _ -> + !Config.record_fields_short_names + | FunId (Pure _ | FromLlbc (FunId (Assumed _), _, _)) -> + (* We map several assumed functions to the same id *) + true | _ -> false -let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) - : extraction_ctx = - (* We do not use the same name map if we allow/disallow collisions *) +(** The [id_to_string] function to print nice debugging messages if there are + collisions *) +let names_maps_add (id_to_string : id -> string) (id : id) (name : string) + (nm : names_maps) : names_maps = + (* We do not use the same name map if we allow/disallow collisions. + We notably use it for field names: some backends like Lean can use the + type information to disambiguate field projections. + + Remark: we still need to check that those "unsafe" ids don't collide with + the ids that we mark as "strict on collision". + + For instance, we don't allow naming a field "let". We enforce this by + not checking collision between ids for which we permit collisions (ex.: + between fields), but still checking collisions between those ids and the + others (ex.: fields and keywords). + *) if allow_collisions id then ( - assert (not is_opaque); + (* Check with the ids which are considered to be strict on collisions *) + names_map_check_collision id_to_string id name nm.strict_names_map; { - ctx with - unsafe_names_map = unsafe_names_map_add id name ctx.unsafe_names_map; + nm with + unsafe_names_map = unsafe_names_map_add id name nm.unsafe_names_map; }) else - (* The id_to_string function to print nice debugging messages if there are - * collisions *) - let id_to_string (id : id) : string = id_to_string id ctx in - let names_map = - names_map_add id_to_string is_opaque id name ctx.names_map + (* Remark: if we are strict on collisions: + - we add the id to the strict collisions map + - we check that the id doesn't collide with the unsafe map + TODO: we might not check that: + - a user defined function doesn't collide with an assumed function + - two trait decl items don't collide with each other + *) + let strict_names_map = + if strict_collisions id then + names_map_add id_to_string id name nm.strict_names_map + else nm.strict_names_map in - { ctx with names_map } + let names_map = names_map_add id_to_string id name nm.names_map in + { nm with strict_names_map; names_map } + +let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = + let id_to_string (id : id) : string = id_to_string id ctx in + let names_maps = names_maps_add id_to_string id name ctx.names_maps in + { ctx with names_maps } -(** [with_opaque_pre]: if [true] and the definition is opaque, add the opaque prefix *) -let ctx_get (with_opaque_pre : bool) (id : id) (ctx : extraction_ctx) : string = +(** The [id_to_string] function to print nice debugging messages if there are + collisions *) +let names_maps_get (id_to_string : id -> string) (id : id) (nm : names_maps) : + string = (* We do not use the same name map if we allow/disallow collisions *) - if allow_collisions id then IdMap.find id ctx.unsafe_names_map.id_to_name + let map_to_string (m : string IdMap.t) : string = + "[\n" + ^ String.concat "," + (List.map + (fun (id, n) -> "\n " ^ id_to_string id ^ " -> " ^ n) + (IdMap.bindings m)) + ^ "\n]" + in + if allow_collisions id then ( + let m = nm.unsafe_names_map.id_to_name in + match IdMap.find_opt id m with + | Some s -> s + | None -> + let err = + "Could not find: " ^ id_to_string id ^ "\nNames map:\n" + ^ map_to_string m + in + log#serror err; + if !Config.fail_hard then raise (Failure err) + else "(%%%ERROR: unknown identifier\": " ^ id_to_string id ^ "\"%%%)") else - match IdMap.find_opt id ctx.names_map.id_to_name with - | Some s -> - let is_opaque = IdSet.mem id ctx.names_map.opaque_ids in - if with_opaque_pre && is_opaque then ctx.fmt.opaque_pre () ^ s else s + let m = nm.names_map.id_to_name in + match IdMap.find_opt id m with + | Some s -> s | None -> - log#serror ("Could not find: " ^ id_to_string id ctx); - raise Not_found + let err = + "Could not find: " ^ id_to_string id ^ "\nNames map:\n" + ^ map_to_string m + in + log#serror err; + if !Config.fail_hard then raise (Failure err) + else "(ERROR: \"" ^ id_to_string id ^ "\")" + +let ctx_get (id : id) (ctx : extraction_ctx) : string = + let id_to_string (id : id) : string = id_to_string id ctx in + names_maps_get id_to_string id ctx.names_maps + +let names_maps_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) + (name : string) (nm : names_maps) : names_maps = + names_maps_add id_to_string (TypeId (Assumed id)) name nm + +let names_maps_add_assumed_struct (id_to_string : id -> string) + (id : assumed_ty) (name : string) (nm : names_maps) : names_maps = + names_maps_add id_to_string (StructId (Assumed id)) name nm -let ctx_get_global (with_opaque_pre : bool) (id : A.GlobalDeclId.id) +let names_maps_add_assumed_variant (id_to_string : id -> string) + (id : assumed_ty) (variant_id : VariantId.id) (name : string) + (nm : names_maps) : names_maps = + names_maps_add id_to_string (VariantId (Assumed id, variant_id)) name nm + +let names_maps_add_function (id_to_string : id -> string) (fid : fun_id) + (name : string) (nm : names_maps) : names_maps = + names_maps_add id_to_string (FunId fid) name nm + +let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get (GlobalId id) ctx + +let ctx_get_function (id : fun_id) (ctx : extraction_ctx) : string = + ctx_get (FunId id) ctx + +let ctx_get_local_function (id : A.FunDeclId.id) (lp : LoopId.id option) + (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = + ctx_get_function (FromLlbc (FunId (Regular id), lp, rg)) ctx + +let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = + assert (id <> Tuple); + ctx_get (TypeId id) ctx + +let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = + ctx_get_type (AdtId id) ctx + +let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = + ctx_get_type (Assumed id) ctx + +let ctx_get_trait_constructor (id : trait_decl_id) (ctx : extraction_ctx) : + string = + ctx_get (TraitDeclConstructorId id) ctx + +let ctx_get_trait_self_clause (ctx : extraction_ctx) : string = + ctx_get TraitSelfClauseId ctx + +let ctx_get_trait_decl (id : trait_decl_id) (ctx : extraction_ctx) : string = + ctx_get (TraitDeclId id) ctx + +let ctx_get_trait_impl (id : trait_impl_id) (ctx : extraction_ctx) : string = + ctx_get (TraitImplId id) ctx + +let ctx_get_trait_item (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get with_opaque_pre (GlobalId id) ctx + ctx_get (TraitItemId (id, item_name)) ctx -let ctx_get_function (with_opaque_pre : bool) (id : fun_id) +let ctx_get_trait_const (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get with_opaque_pre (FunId id) ctx + ctx_get_trait_item id item_name ctx -let ctx_get_local_function (with_opaque_pre : bool) (id : A.FunDeclId.id) - (lp : LoopId.id option) (rg : RegionGroupId.id option) +let ctx_get_trait_type (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - ctx_get_function with_opaque_pre (FromLlbc (Regular id, lp, rg)) ctx + ctx_get_trait_item id item_name ctx -let ctx_get_type (with_opaque_pre : bool) (id : type_id) (ctx : extraction_ctx) - : string = - assert (id <> Tuple); - ctx_get with_opaque_pre (TypeId id) ctx +let ctx_get_trait_method (id : trait_decl_id) (item_name : string) + (rg_id : T.RegionGroupId.id option) (ctx : extraction_ctx) : string = + ctx_get (TraitMethodId (id, item_name, rg_id)) ctx -let ctx_get_local_type (with_opaque_pre : bool) (id : TypeDeclId.id) +let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - ctx_get_type with_opaque_pre (AdtId id) ctx + ctx_get (TraitParentClauseId (id, clause)) ctx -let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = - (* In practice, the assumed types are opaque. However, assumed types - are never grouped in the opaque module, meaning we never need to - prefix them: we thus consider them as non-opaque with regards to the - names map. - *) - let is_opaque = false in - ctx_get_type is_opaque (Assumed id) ctx +let ctx_get_trait_item_clause (id : trait_decl_id) (item : string) + (clause : trait_clause_id) (ctx : extraction_ctx) : string = + ctx_get (TraitItemClauseId (id, item, clause)) ctx let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (VarId id) ctx + ctx_get (VarId id) ctx let ctx_get_type_var (id : TypeVarId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (TypeVarId id) ctx + ctx_get (TypeVarId id) ctx let ctx_get_const_generic_var (id : ConstGenericVarId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (ConstGenericVarId id) ctx + ctx_get (ConstGenericVarId id) ctx + +let ctx_get_local_trait_clause (id : TraitClauseId.id) (ctx : extraction_ctx) : + string = + ctx_get (LocalTraitClauseId id) ctx let ctx_get_field (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (FieldId (type_id, field_id)) ctx + ctx_get (FieldId (type_id, field_id)) ctx -let ctx_get_struct (with_opaque_pre : bool) (def_id : type_id) - (ctx : extraction_ctx) : string = - ctx_get with_opaque_pre (StructId def_id) ctx +let ctx_get_struct (def_id : type_id) (ctx : extraction_ctx) : string = + ctx_get (StructId def_id) ctx let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (VariantId (def_id, variant_id)) ctx + ctx_get (VariantId (def_id, variant_id)) ctx let ctx_get_decreases_proof (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (DecreasesProofId (Regular def_id, loop_id)) ctx + ctx_get (DecreasesProofId (Regular def_id, loop_id)) ctx let ctx_get_termination_measure (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (TerminationMeasureId (Regular def_id, loop_id)) ctx + ctx_get (TerminationMeasureId (Regular def_id, loop_id)) ctx (** Generate a unique type variable name and add it to the context *) let ctx_add_type_var (basename : string) (id : TypeVarId.id) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in - let name = ctx.fmt.type_var_basename ctx.names_map.names_set basename in let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name + ctx.fmt.type_var_basename ctx.names_maps.names_map.names_set basename + in + let name = + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + name in - let ctx = ctx_add is_opaque (TypeVarId id) name ctx in + let ctx = ctx_add (TypeVarId id) name ctx in (ctx, name) (** Generate a unique const generic variable name and add it to the context *) let ctx_add_const_generic_var (basename : string) (id : ConstGenericVarId.id) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in let name = - ctx.fmt.const_generic_var_basename ctx.names_map.names_set basename + ctx.fmt.const_generic_var_basename ctx.names_maps.names_map.names_set + basename in let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + name in - let ctx = ctx_add is_opaque (ConstGenericVarId id) name ctx in + let ctx = ctx_add (ConstGenericVarId id) name ctx in (ctx, name) (** See {!ctx_add_type_var} *) @@ -856,11 +1070,31 @@ let ctx_add_type_vars (vars : (string * TypeVarId.id) list) (** Generate a unique variable name and add it to the context *) let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + basename in - let ctx = ctx_add is_opaque (VarId id) name ctx in + let ctx = ctx_add (VarId id) name ctx in + (ctx, name) + +(** Generate a unique variable name for the trait self clause and add it to the context *) +let ctx_add_trait_self_clause (ctx : extraction_ctx) : extraction_ctx * string = + let basename = ctx.fmt.trait_self_clause_basename in + let name = + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + basename + in + let ctx = ctx_add TraitSelfClauseId name ctx in + (ctx, name) + +(** Generate a unique trait clause name and add it to the context *) +let ctx_add_local_trait_clause (basename : string) (id : TraitClauseId.id) + (ctx : extraction_ctx) : extraction_ctx * string = + let name = + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + basename + in + let ctx = ctx_add (LocalTraitClauseId id) name ctx in (ctx, name) (** See {!ctx_add_var} *) @@ -868,7 +1102,9 @@ let ctx_add_vars (vars : var list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (v : var) -> - let name = ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty in + let name = + ctx.fmt.var_basename ctx.names_maps.names_map.names_set v.basename v.ty + in ctx_add_var name v.id ctx) ctx vars @@ -885,142 +1121,105 @@ let ctx_add_const_generic_params (vars : const_generic_var list) ctx_add_const_generic_var var.name var.index ctx) ctx vars -let ctx_add_type_const_generic_params (tvars : type_var list) - (cgvars : const_generic_var list) (ctx : extraction_ctx) : - extraction_ctx * string list * string list = - let ctx, tys = ctx_add_type_params tvars ctx in - let ctx, cgs = ctx_add_const_generic_params cgvars ctx in - (ctx, tys, cgs) - -let ctx_add_type_decl_struct (def : type_decl) (ctx : extraction_ctx) : - extraction_ctx * string = - assert (match def.kind with Struct _ -> true | _ -> false); - let is_opaque = false in - let cons_name = ctx.fmt.struct_constructor def.name in - let ctx = ctx_add is_opaque (StructId (AdtId def.def_id)) cons_name ctx in - (ctx, cons_name) - -let ctx_add_type_decl (def : type_decl) (ctx : extraction_ctx) : extraction_ctx - = - let is_opaque = def.kind = Opaque in - let def_name = ctx.fmt.type_name def.name in - let ctx = ctx_add is_opaque (TypeId (AdtId def.def_id)) def_name ctx in - ctx - -let ctx_add_field (def : type_decl) (field_id : FieldId.id) (field : field) - (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in - let name = ctx.fmt.field_name def.name field_id field.field_name in - let ctx = ctx_add is_opaque (FieldId (AdtId def.def_id, field_id)) name ctx in - (ctx, name) - -let ctx_add_fields (def : type_decl) (fields : (FieldId.id * field) list) +let ctx_add_local_trait_clauses (clauses : trait_clause list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map - (fun ctx (vid, v) -> ctx_add_field def vid v ctx) - ctx fields - -let ctx_add_variant (def : type_decl) (variant_id : VariantId.id) - (variant : variant) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in - let name = ctx.fmt.variant_name def.name variant.variant_name in - (* Add the type name prefix for Lean *) - let name = - if !Config.backend = Lean then - let type_name = ctx.fmt.type_name def.name in - type_name ^ "." ^ name - else name - in - let ctx = - ctx_add is_opaque (VariantId (AdtId def.def_id, variant_id)) name ctx - in - (ctx, name) - -let ctx_add_variants (def : type_decl) - (variants : (VariantId.id * variant) list) (ctx : extraction_ctx) : - extraction_ctx * string list = - List.fold_left_map - (fun ctx (vid, v) -> ctx_add_variant def vid v ctx) - ctx variants + (fun ctx (c : trait_clause) -> + let basename = + ctx.fmt.trait_clause_basename ctx.names_maps.names_map.names_set c + in + ctx_add_local_trait_clause basename c.clause_id ctx) + ctx clauses -let ctx_add_struct (def : type_decl) (ctx : extraction_ctx) : - extraction_ctx * string = - assert (match def.kind with Struct _ -> true | _ -> false); - let is_opaque = false in - let name = ctx.fmt.struct_constructor def.name in - let ctx = ctx_add is_opaque (StructId (AdtId def.def_id)) name ctx in - (ctx, name) +(** Returns the lists of names for: + - the type variables + - the const generic variables + - the trait clauses + *) +let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : + extraction_ctx * string list * string list * string list = + let { types; const_generics; trait_clauses } = generics in + let ctx, tys = ctx_add_type_params types ctx in + let ctx, cgs = ctx_add_const_generic_params const_generics ctx in + let ctx, tcs = ctx_add_local_trait_clauses trait_clauses ctx in + (ctx, tys, cgs, tcs) let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = - let is_opaque = false in let name = ctx.fmt.decreases_proof_name def.def_id def.basename def.num_loops def.loop_id in - ctx_add is_opaque - (DecreasesProofId (Regular def.def_id, def.loop_id)) - name ctx + ctx_add (DecreasesProofId (Regular def.def_id, def.loop_id)) name ctx let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = - let is_opaque = false in let name = ctx.fmt.termination_measure_name def.def_id def.basename def.num_loops def.loop_id in - ctx_add is_opaque - (TerminationMeasureId (Regular def.def_id, def.loop_id)) - name ctx + ctx_add (TerminationMeasureId (Regular def.def_id, def.loop_id)) name ctx let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = (* TODO: update once the body id can be an option *) - let is_opaque = false in - let name = ctx.fmt.global_name def.name in let decl = GlobalId def.def_id in - let body = FunId (FromLlbc (Regular def.body_id, None, None)) in - let ctx = ctx_add is_opaque decl (name ^ "_c") ctx in - let ctx = ctx_add is_opaque body (name ^ "_body") ctx in - ctx -let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) - (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = - (* Sanity check: the function should not be a global body - those are handled - * separately *) - assert (not def.is_global_decl_body); + (* Check if the global corresponds to an assumed global that we should map + to a custom definition in our standard library (for instance, happens + with "core::num::usize::MAX") *) + let sname = name_to_simple_name def.name in + match SimpleNameMap.find_opt sname builtin_globals_map with + | Some name -> + (* Yes: register the custom binding *) + ctx_add decl name ctx + | None -> + (* Not the case: "standard" registration *) + let name = ctx.fmt.global_name def.name in + let body = FunId (FromLlbc (FunId (Regular def.body_id), None, None)) in + let ctx = ctx_add decl (name ^ "_c") ctx in + let ctx = ctx_add body (name ^ "_body") ctx in + ctx + +let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) + (ctx : extraction_ctx) : string = (* Lookup the LLBC def to compute the region group information *) let def_id = def.def_id in - let llbc_def = - A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_context.fun_decls - in + let llbc_def = A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_ctx.fun_decls in let sg = llbc_def.signature in let num_rgs = List.length sg.regions_hierarchy in - let keep_fwd, (_, backs) = trans_group in + let { keep_fwd; fwd = _; backs } = trans_group in let num_backs = List.length backs in let rg_info = match def.back_id with | None -> None | Some rg_id -> let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in - let regions = + let region_names = List.map - (fun rid -> T.RegionVarId.nth sg.region_params rid) + (fun rid -> (T.RegionVarId.nth sg.generics.regions rid).name) rg.regions in - let region_names = - List.map (fun (r : T.region_var) -> r.name) regions - in Some { id = rg_id; region_names } in - let is_opaque = def.body = None in (* Add the function name *) - let def_name = - ctx.fmt.fun_name def.basename def.num_loops def.loop_id num_rgs rg_info - (keep_fwd, num_backs) - in - let fun_id = (A.Regular def_id, def.loop_id, def.back_id) in - let ctx = ctx_add is_opaque (FunId (FromLlbc fun_id)) def_name ctx in + ctx.fmt.fun_name def.basename def.num_loops def.loop_id num_rgs rg_info + (keep_fwd, num_backs) + +(* TODO: move to Extract *) +let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) + (ctx : extraction_ctx) : extraction_ctx = + (* Sanity check: the function should not be a global body - those are handled + * separately *) + assert (not def.is_global_decl_body); + (* Lookup the LLBC def to compute the region group information *) + let def_id = def.def_id in + let { keep_fwd; fwd = _; backs } = trans_group in + let num_backs = List.length backs in + (* Add the function name *) + let def_name = ctx_compute_fun_name trans_group def ctx in + let fun_id = (Pure.FunId (Regular def_id), def.loop_id, def.back_id) in + let ctx = ctx_add (FunId (FromLlbc fun_id)) def_name ctx in (* Add the name info *) { ctx with @@ -1039,9 +1238,10 @@ type names_map_init = { assumed_pure_functions : (pure_assumed_fun_id * string) list; } -(** Initialize a names map with a proper set of keywords/names coming from the +(** Initialize names maps with a proper set of keywords/names coming from the target language/prover. *) -let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = +let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps + = let int_names = List.map fmt.int_name T.all_int_types in let keywords = List.concat @@ -1049,20 +1249,30 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = [ fmt.bool_name; fmt.char_name; fmt.str_name ]; int_names; init.keywords; ] in - let names_set = StringSet.of_list keywords in - let name_to_id = - StringMap.of_list (List.map (fun x -> (x, UnknownId)) keywords) - in - let opaque_ids = IdSet.empty in + let names_set = StringSet.empty in + let name_to_id = StringMap.empty in (* We fist initialize [id_to_name] as empty, because the id of a keyword is [UnknownId]. * Also note that we don't need this mapping for keywords: we insert keywords only * to check collisions. *) let id_to_name = IdMap.empty in - let nm = { id_to_name; name_to_id; names_set; opaque_ids } in + let names_map = { id_to_name; name_to_id; names_set } in + let unsafe_names_map = empty_unsafe_names_map in + let strict_names_map = empty_names_map in (* For debugging - we are creating bindings for assumed types and functions, so * it is ok if we simply use the "show" function (those aren't simply identified * by numbers) *) let id_to_string = show_id in + (* Add the keywords as strict collisions *) + let strict_names_map = + List.fold_left + (fun nm name -> + (* There is duplication in the keywords so we don't check the collisions + while registering them (what is important is that there are no collisions + between keywords and user-defined identifiers) *) + names_map_add_unchecked UnknownId name nm) + strict_names_map keywords + in + let nm = { names_map; unsafe_names_map; strict_names_map } in (* Then we add: * - the assumed types * - the assumed struct constructors @@ -1072,37 +1282,31 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = let nm = List.fold_left (fun nm (type_id, name) -> - names_map_add_assumed_type id_to_string type_id name nm) + names_maps_add_assumed_type id_to_string type_id name nm) nm init.assumed_adts in let nm = List.fold_left (fun nm (type_id, name) -> - names_map_add_assumed_struct id_to_string type_id name nm) + names_maps_add_assumed_struct id_to_string type_id name nm) nm init.assumed_structs in let nm = List.fold_left (fun nm (type_id, variant_id, name) -> - names_map_add_assumed_variant id_to_string type_id variant_id name nm) + names_maps_add_assumed_variant id_to_string type_id variant_id name nm) nm init.assumed_variants in let assumed_functions = List.map - (fun (fid, rg, name) -> (FromLlbc (A.Assumed fid, None, rg), name)) + (fun (fid, rg, name) -> + (FromLlbc (Pure.FunId (Assumed fid), None, rg), name)) init.assumed_llbc_functions @ List.map (fun (fid, name) -> (Pure fid, name)) init.assumed_pure_functions in let nm = - (* In practice, the assumed function are opaque. However, assumed functions - are never grouped in the opaque module, meaning we never need to - prefix them: we thus consider them as non-opaque with regards to the - names map. - *) - let is_opaque = false in List.fold_left - (fun nm (fid, name) -> - names_map_add_function id_to_string is_opaque fid name nm) + (fun nm (fid, name) -> names_maps_add_function id_to_string fid name nm) nm assumed_functions in (* Return *) @@ -1150,22 +1354,20 @@ let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) let rg_suff = (* TODO: make all the backends match what is done for Lean *) match rg with - | None -> ( - match !Config.backend with - | FStar | Coq | HOL4 -> "_fwd" - | Lean -> - (* In order to avoid name conflicts: - * - if the forward is eliminated, we add the suffix "_fwd" (it won't be used) - * - otherwise, no suffix (because the backward functions will have a suffix) - *) - if num_backs = 1 && not keep_fwd then "_fwd" else "") + | None -> + if + (* In order to avoid name conflicts: + * - if the forward is eliminated, we add the suffix "_fwd" (it won't be used) + * - otherwise, no suffix (because the backward functions will have a suffix) + *) + num_backs = 1 && not keep_fwd + then "_fwd" + else "" | Some rg -> assert (num_region_groups > 0 && num_backs > 0); if num_backs = 1 then (* Exactly one backward function *) - match !Config.backend with - | FStar | Coq | HOL4 -> if not keep_fwd then "_fwd_back" else "_back" - | Lean -> if not keep_fwd then "" else "_back" + if not keep_fwd then "" else "_back" else if (* Several region groups/backward functions: - if all the regions in the group have names, we use those names diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml new file mode 100644 index 00000000..a54ab604 --- /dev/null +++ b/compiler/ExtractBuiltin.ml @@ -0,0 +1,648 @@ +(** This file declares external identifiers that we catch to map them to + definitions coming from the standard libraries in our backends. + + TODO: there misses trait **implementations** + *) + +open Names +open Config + +type simple_name = string list [@@deriving show, ord] + +let name_to_simple_name (s : name) : simple_name = + (* We simply ignore the disambiguators *) + List.filter_map (function Ident id -> Some id | Disambiguator _ -> None) s + +(** Small helper which cuts a string at the occurrences of "::" *) +let string_to_simple_name (s : string) : simple_name = + (* No function to split by using string separator?? *) + let name = String.split_on_char ':' s in + List.filter (fun s -> s <> "") name + +module SimpleNameOrd = struct + type t = simple_name + + let compare = compare_simple_name + let to_string = show_simple_name + let pp_t = pp_simple_name + let show_t = show_simple_name +end + +module SimpleNameMap = Collections.MakeMap (SimpleNameOrd) +module SimpleNameSet = Collections.MakeSet (SimpleNameOrd) + +(** Small utility to memoize some computations *) +let mk_memoized (f : unit -> 'a) : unit -> 'a = + let r = ref None in + let g () = + match !r with + | Some x -> x + | None -> + let x = f () in + r := Some x; + x + in + g + +(** Switch between two values depending on the target backend. + + We often compute the same value (typically: a name) if the target + is F*, Coq or HOL4, and a different value if the target is Lean. + *) +let backend_choice (fstar_coq_hol4 : 'a) (lean : 'a) : 'a = + match !backend with Coq | FStar | HOL4 -> fstar_coq_hol4 | Lean -> lean + +let builtin_globals : (string * string) list = + [ + (* Min *) + ("core::num::usize::MIN", "core_usize_min"); + ("core::num::u8::MIN", "core_u8_min"); + ("core::num::u16::MIN", "core_u16_min"); + ("core::num::u32::MIN", "core_u32_min"); + ("core::num::u64::MIN", "core_u64_min"); + ("core::num::u128::MIN", "core_u128_min"); + ("core::num::isize::MIN", "core_isize_min"); + ("core::num::i8::MIN", "core_i8_min"); + ("core::num::i16::MIN", "core_i16_min"); + ("core::num::i32::MIN", "core_i32_min"); + ("core::num::i64::MIN", "core_i64_min"); + ("core::num::i128::MIN", "core_i128_min"); + (* Max *) + ("core::num::usize::MAX", "core_usize_max"); + ("core::num::u8::MAX", "core_u8_max"); + ("core::num::u16::MAX", "core_u16_max"); + ("core::num::u32::MAX", "core_u32_max"); + ("core::num::u64::MAX", "core_u64_max"); + ("core::num::u128::MAX", "core_u128_max"); + ("core::num::isize::MAX", "core_isize_max"); + ("core::num::i8::MAX", "core_i8_max"); + ("core::num::i16::MAX", "core_i16_max"); + ("core::num::i32::MAX", "core_i32_max"); + ("core::num::i64::MAX", "core_i64_max"); + ("core::num::i128::MAX", "core_i128_max"); + ] + +let builtin_globals_map : string SimpleNameMap.t = + SimpleNameMap.of_list + (List.map (fun (x, y) -> (string_to_simple_name x, y)) builtin_globals) + +type builtin_variant_info = { fields : (string * string) list } +[@@deriving show] + +type builtin_enum_variant_info = { + rust_variant_name : string; + extract_variant_name : string; + fields : string list option; +} +[@@deriving show] + +type builtin_type_body_info = + | Struct of string * (string * string) list + (* The constructor name and the map for the field names *) + | Enum of builtin_enum_variant_info list +(* For every variant, a map for the field names *) +[@@deriving show] + +type builtin_type_info = { + rust_name : string list; + extract_name : string; + keep_params : bool list option; + (** We might want to filter some of the type parameters. + + For instance, `Vec` type takes a type parameter for the allocator, + which we want to ignore. + *) + body_info : builtin_type_body_info option; +} +[@@deriving show] + +type type_variant_kind = + | KOpaque + | KStruct of (string * string) list + (* TODO: handle the tuple case *) + | KEnum (* TODO *) + +let mk_struct_constructor (type_name : string) : string = + let prefix = + match !backend with FStar -> "Mk" | Coq | HOL4 -> "mk" | Lean -> "" + in + let suffix = match !backend with FStar | Coq | HOL4 -> "" | Lean -> ".mk" in + prefix ^ type_name ^ suffix + +(** The assumed types. + + The optional list of booleans is filtering information for the type + parameters. For instance, in the case of the `Vec` functions, there is + a type parameter for the allocator to use, which we want to filter. + *) +let builtin_types () : builtin_type_info list = + let mk_type (rust_name : string list) ?(keep_params : bool list option = None) + ?(kind : type_variant_kind = KOpaque) () : builtin_type_info = + let extract_name = + let sep = backend_choice "_" "." in + String.concat sep rust_name + in + let body_info : builtin_type_body_info option = + match kind with + | KOpaque -> None + | KStruct fields -> + let fields = + List.map + (fun (rname, name) -> + ( rname, + match !backend with + | FStar | Lean -> name + | Coq | HOL4 -> extract_name ^ "_" ^ name )) + fields + in + let constructor = mk_struct_constructor extract_name in + Some (Struct (constructor, fields)) + | KEnum -> raise (Failure "TODO") + in + { rust_name; extract_name; keep_params; body_info } + in + + [ + (* Alloc *) + mk_type [ "alloc"; "alloc"; "Global" ] (); + (* Vec *) + mk_type [ "alloc"; "vec"; "Vec" ] ~keep_params:(Some [ true; false ]) (); + (* Range *) + mk_type + [ "core"; "ops"; "range"; "Range" ] + ~kind:(KStruct [ ("start", "start"); ("end", "end_") ]) + (); + (* Option + + This one is more custom because we use the standard "option" type from + the target backend. + *) + { + rust_name = [ "core"; "option"; "Option" ]; + extract_name = + (match !backend with + | Lean -> "Option" + | Coq | FStar | HOL4 -> "option"); + keep_params = None; + body_info = + Some + (Enum + [ + { + rust_variant_name = "None"; + extract_variant_name = + (match !backend with + | FStar | Coq -> "None" + | Lean -> "none" + | HOL4 -> "NONE"); + fields = None; + }; + { + rust_variant_name = "Some"; + extract_variant_name = + (match !backend with + | FStar | Coq -> "Some" + | Lean -> "some" + | HOL4 -> "SOME"); + fields = None; + }; + ]); + }; + ] + +let mk_builtin_types_map () = + SimpleNameMap.of_list + (List.map (fun info -> (info.rust_name, info)) (builtin_types ())) + +let builtin_types_map = mk_memoized mk_builtin_types_map + +type builtin_fun_info = { + rg : Types.RegionGroupId.id option; + extract_name : string; +} +[@@deriving show] + +(** The assumed functions. + + The optional list of booleans is filtering information for the type + parameters. For instance, in the case of the `Vec` functions, there is + a type parameter for the allocator to use, which we want to filter. + *) +let builtin_funs () : + (string list * bool list option * builtin_fun_info list) list = + let rg0 = Some Types.RegionGroupId.zero in + (* Small utility *) + let mk_fun (name : string list) (extract_name : string list option) + (filter : bool list option) (with_back : bool) (back_no_suffix : bool) : + string list * bool list option * builtin_fun_info list = + let extract_name = + match extract_name with None -> name | Some name -> name + in + let basename = + match !backend with + | FStar | Coq | HOL4 -> String.concat "_" extract_name + | Lean -> String.concat "." extract_name + in + let fwd_suffix = if with_back && back_no_suffix then "_fwd" else "" in + let fwd = [ { rg = None; extract_name = basename ^ fwd_suffix } ] in + let back_suffix = if with_back && back_no_suffix then "" else "_back" in + let back = + if with_back then [ { rg = rg0; extract_name = basename ^ back_suffix } ] + else [] + in + (name, filter, fwd @ back) + in + [ + mk_fun [ "core"; "mem"; "replace" ] None None true false; + mk_fun [ "alloc"; "vec"; "Vec"; "new" ] None None false false; + mk_fun + [ "alloc"; "vec"; "Vec"; "push" ] + None + (Some [ true; false ]) + true true; + mk_fun + [ "alloc"; "vec"; "Vec"; "insert" ] + None + (Some [ true; false ]) + true true; + mk_fun + [ "alloc"; "vec"; "Vec"; "len" ] + None + (Some [ true; false ]) + true false; + mk_fun + [ "alloc"; "vec"; "Vec"; "index" ] + None + (Some [ true; true; false ]) + true false; + mk_fun + [ "alloc"; "vec"; "Vec"; "index_mut" ] + None + (Some [ true; true; false ]) + true false; + mk_fun + [ "alloc"; "boxed"; "Box"; "deref" ] + None + (Some [ true; false ]) + true false; + mk_fun + [ "alloc"; "boxed"; "Box"; "deref_mut" ] + None + (Some [ true; false ]) + true false; + (* TODO: fix the same like "[T]" below *) + mk_fun + [ "core"; "slice"; "index"; "[T]"; "index" ] + (Some [ "core"; "slice"; "index"; "Slice"; "index" ]) + None true false; + mk_fun + [ "core"; "slice"; "index"; "[T]"; "index_mut" ] + (Some [ "core"; "slice"; "index"; "Slice"; "index_mut" ]) + None true false; + mk_fun + [ "core"; "array"; "[T; N]"; "index" ] + (Some [ "core"; "array"; "Array"; "index" ]) + None true false; + mk_fun + [ "core"; "array"; "[T; N]"; "index_mut" ] + (Some [ "core"; "array"; "Array"; "index_mut" ]) + None true false; + mk_fun [ "core"; "slice"; "index"; "Range"; "get" ] None None true false; + mk_fun [ "core"; "slice"; "index"; "Range"; "get_mut" ] None None true false; + mk_fun [ "core"; "slice"; "index"; "Range"; "index" ] None None true false; + mk_fun + [ "core"; "slice"; "index"; "Range"; "index_mut" ] + None None true false; + mk_fun + [ "core"; "slice"; "index"; "Range"; "get_unchecked" ] + None None false false; + mk_fun + [ "core"; "slice"; "index"; "Range"; "get_unchecked_mut" ] + None None false false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "get" ] + (Some [ "core"; "slice"; "index"; "Usize"; "get" ]) + None true false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "get_mut" ] + (Some [ "core"; "slice"; "index"; "Usize"; "get_mut" ]) + None true false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "get_unchecked" ] + (Some [ "core"; "slice"; "index"; "Usize"; "get_unchecked" ]) + None false false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "get_unchecked_mut" ] + (Some [ "core"; "slice"; "index"; "Usize"; "get_unchecked_mut" ]) + None false false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "index" ] + (Some [ "core"; "slice"; "index"; "Usize"; "index" ]) + None true false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "index_mut" ] + (Some [ "core"; "slice"; "index"; "Usize"; "index_mut" ]) + None true false; + ] + +let mk_builtin_funs_map () = + SimpleNameMap.of_list + (List.map + (fun (name, filter, info) -> (name, (filter, info))) + (builtin_funs ())) + +let builtin_funs_map = mk_memoized mk_builtin_funs_map + +type effect_info = { can_fail : bool; stateful : bool } + +let builtin_fun_effects = + let int_names = + [ + "usize"; + "u8"; + "u16"; + "u32"; + "u64"; + "u128"; + "isize"; + "i8"; + "i16"; + "i32"; + "i64"; + "i128"; + ] + in + let int_ops = + [ "wrapping_add"; "wrapping_sub"; "rotate_left"; "rotate_right" ] + in + let int_funs = + List.map + (fun int_name -> + List.map (fun op -> "core::num::" ^ int_name ^ "::" ^ op) int_ops) + int_names + in + let int_funs = List.concat int_funs in + let no_fail_no_state_funs = + [ + (* TODO: redundancy with the funs information below *) + "alloc::vec::Vec::new"; + "alloc::vec::Vec::len"; + "alloc::boxed::Box::deref"; + "alloc::boxed::Box::deref_mut"; + "core::mem::replace"; + "core::mem::take"; + ] + @ int_funs + in + let no_fail_no_state_funs = + List.map + (fun n -> (n, { can_fail = false; stateful = false })) + no_fail_no_state_funs + in + let no_state_funs = + [ + (* TODO: redundancy with the funs information below *) + "alloc::vec::Vec::push"; + "alloc::vec::Vec::index"; + "alloc::vec::Vec::index_mut"; + "alloc::vec::Vec::index_mut_back"; + ] + in + let no_state_funs = + List.map (fun n -> (n, { can_fail = true; stateful = false })) no_state_funs + in + no_fail_no_state_funs @ no_state_funs + +let builtin_fun_effects_map = + SimpleNameMap.of_list + (List.map (fun (n, x) -> (string_to_simple_name n, x)) builtin_fun_effects) + +type builtin_trait_decl_info = { + rust_name : string; + extract_name : string; + constructor : string; + parent_clauses : string list; + consts : (string * string) list; + types : (string * (string * string list)) list; + (** Every type has: + - a Rust name + - an extraction name + - a list of clauses *) + methods : (string * builtin_fun_info list) list; +} +[@@deriving show] + +let builtin_trait_decls_info () = + let rg0 = Some Types.RegionGroupId.zero in + let mk_trait (rust_name : string list) ?(extract_name : string option = None) + ?(parent_clauses : string list = []) ?(types : string list = []) + ?(methods : (string * bool) list = []) () : builtin_trait_decl_info = + let extract_name = + match extract_name with + | Some n -> n + | None -> ( + match !backend with + | Coq | FStar | HOL4 -> String.concat "_" rust_name + | Lean -> String.concat "." rust_name) + in + let constructor = mk_struct_constructor extract_name in + let consts = [] in + let types = + let mk_type item_name = + let type_name = + match !backend with + | Coq | FStar | HOL4 -> extract_name ^ "_" ^ item_name + | Lean -> item_name + in + let clauses = [] in + (item_name, (type_name, clauses)) + in + List.map mk_type types + in + let methods = + let mk_method (item_name, with_back) = + (* TODO: factor out with builtin_funs_info *) + let basename = + match !backend with + | Coq | FStar | HOL4 -> extract_name ^ "_" ^ item_name + | Lean -> item_name + in + let back_no_suffix = false in + let fwd_suffix = if with_back && back_no_suffix then "_fwd" else "" in + let fwd = [ { rg = None; extract_name = basename ^ fwd_suffix } ] in + let back_suffix = if with_back && back_no_suffix then "" else "_back" in + let back = + if with_back then + [ { rg = rg0; extract_name = basename ^ back_suffix } ] + else [] + in + (item_name, fwd @ back) + in + List.map mk_method methods + in + let rust_name = String.concat "::" rust_name in + { + rust_name; + extract_name; + constructor; + parent_clauses; + consts; + types; + methods; + } + in + [ + (* Deref *) + mk_trait + [ "core"; "ops"; "deref"; "Deref" ] + ~types:[ "Target" ] + ~methods:[ ("deref", true) ] + (); + (* DerefMut *) + mk_trait + [ "core"; "ops"; "deref"; "DerefMut" ] + ~parent_clauses:[ backend_choice "deref_inst" "derefInst" ] + ~methods:[ ("deref_mut", true) ] + (); + (* Index *) + mk_trait + [ "core"; "ops"; "index"; "Index" ] + ~types:[ "Output" ] + ~methods:[ ("index", true) ] + (); + (* IndexMut *) + mk_trait + [ "core"; "ops"; "index"; "IndexMut" ] + ~parent_clauses:[ backend_choice "index_inst" "indexInst" ] + ~methods:[ ("index_mut", true) ] + (); + (* Sealed *) + mk_trait [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] (); + (* SliceIndex *) + mk_trait + [ "core"; "slice"; "index"; "SliceIndex" ] + ~parent_clauses:[ backend_choice "sealed_inst" "sealedInst" ] + ~types:[ "Output" ] + ~methods: + [ + ("get", true); + ("get_mut", true); + ("get_unchecked", false); + ("get_unchecked_mut", false); + ("index", true); + ("index_mut", true); + ] + (); + ] + +let mk_builtin_trait_decls_map () = + SimpleNameMap.of_list + (List.map + (fun info -> (string_to_simple_name info.rust_name, info)) + (builtin_trait_decls_info ())) + +let builtin_trait_decls_map = mk_memoized mk_builtin_trait_decls_map + +(* TODO: generalize this. + + For now, the key is: + - name of the impl (ex.: "alloc.boxed.Boxed") + - name of the implemented trait (ex.: "core.ops.deref.Deref" +*) +type simple_name_pair = simple_name * simple_name [@@deriving show, ord] + +module SimpleNamePairOrd = struct + type t = simple_name_pair + + let compare = compare_simple_name_pair + let to_string = show_simple_name_pair + let pp_t = pp_simple_name_pair + let show_t = show_simple_name_pair +end + +module SimpleNamePairMap = Collections.MakeMap (SimpleNamePairOrd) + +let builtin_trait_impls_info () : + ((string list * string list) * (bool list option * string)) list = + let fmt (type_name : string list) + ?(extract_type_name : string list option = None) + (trait_name : string list) ?(filter : bool list option = None) () : + (string list * string list) * (bool list option * string) = + let name = + let trait_name = String.concat "" trait_name ^ "Inst" in + let sep = backend_choice "_" "." in + let type_name = + match extract_type_name with + | Some type_name -> type_name + | None -> type_name + in + String.concat sep type_name ^ sep ^ trait_name + in + ((type_name, trait_name), (filter, name)) + in + (* TODO: fix the names like "[T]" below *) + [ + (* core::ops::Deref<alloc::boxed::Box<T>> *) + fmt [ "alloc"; "boxed"; "Box" ] [ "core"; "ops"; "deref"; "Deref" ] (); + (* core::ops::DerefMut<alloc::boxed::Box<T>> *) + fmt [ "alloc"; "boxed"; "Box" ] [ "core"; "ops"; "deref"; "DerefMut" ] (); + (* core::ops::index::Index<[T], I> *) + fmt + [ "core"; "slice"; "index"; "[T]" ] + ~extract_type_name:(Some [ "core"; "slice"; "index"; "Slice" ]) + [ "core"; "ops"; "index"; "Index" ] + (); + (* core::ops::index::IndexMut<[T], I> *) + fmt + [ "core"; "slice"; "index"; "[T]" ] + ~extract_type_name:(Some [ "core"; "slice"; "index"; "Slice" ]) + [ "core"; "ops"; "index"; "IndexMut" ] + (); + (* core::slice::index::private_slice_index::Sealed<Range<usize>> *) + fmt + [ "core"; "slice"; "index"; "private_slice_index"; "Range" ] + [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] + (); + (* core::slice::index::SliceIndex<Range<usize>, [T]> *) + fmt + [ "core"; "slice"; "index"; "Range" ] + [ "core"; "slice"; "index"; "SliceIndex" ] + (); + (* core::ops::index::Index<[T; N], I> *) + fmt + [ "core"; "array"; "[T; N]" ] + ~extract_type_name:(Some [ "core"; "array"; "Array" ]) + [ "core"; "ops"; "index"; "Index" ] + (); + (* core::ops::index::IndexMut<[T; N], I> *) + fmt + [ "core"; "array"; "[T; N]" ] + ~extract_type_name:(Some [ "core"; "array"; "Array" ]) + [ "core"; "ops"; "index"; "IndexMut" ] + (); + (* core::slice::index::private_slice_index::Sealed<usize> *) + fmt + [ "core"; "slice"; "index"; "private_slice_index"; "usize" ] + [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] + (); + (* core::slice::index::SliceIndex<usize, [T]> *) + fmt + [ "core"; "slice"; "index"; "usize" ] + [ "core"; "slice"; "index"; "SliceIndex" ] + (); + (* core::ops::index::Index<Vec<T>, T> *) + fmt [ "alloc"; "vec"; "Vec" ] + [ "core"; "ops"; "index"; "Index" ] + ~filter:(Some [ true; true; false ]) + (); + (* core::ops::index::IndexMut<Vec<T>, T> *) + fmt [ "alloc"; "vec"; "Vec" ] + [ "core"; "ops"; "index"; "IndexMut" ] + ~filter:(Some [ true; true; false ]) + (); + ] + +let mk_builtin_trait_impls_map () = + SimpleNamePairMap.of_list (builtin_trait_impls_info ()) + +let builtin_trait_impls_map = mk_memoized mk_builtin_trait_impls_map diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml new file mode 100644 index 00000000..77f76bb4 --- /dev/null +++ b/compiler/ExtractTypes.ml @@ -0,0 +1,2477 @@ +(** The generic extraction *) +(* Turn the whole module into a functor: it is very annoying to carry the + the formatter everywhere... +*) + +open Pure +open PureUtils +open TranslateCore +open ExtractBase +open StringUtils +open Config +module F = Format + +(** Small helper to compute the name of an int type *) +let int_name (int_ty : integer_type) = + let isize, usize, i_format, u_format = + match !backend with + | FStar | Coq | HOL4 -> + ("isize", "usize", format_of_string "i%d", format_of_string "u%d") + | Lean -> ("Isize", "Usize", format_of_string "I%d", format_of_string "U%d") + in + match int_ty with + | Isize -> isize + | I8 -> Printf.sprintf i_format 8 + | I16 -> Printf.sprintf i_format 16 + | I32 -> Printf.sprintf i_format 32 + | I64 -> Printf.sprintf i_format 64 + | I128 -> Printf.sprintf i_format 128 + | Usize -> usize + | U8 -> Printf.sprintf u_format 8 + | U16 -> Printf.sprintf u_format 16 + | U32 -> Printf.sprintf u_format 32 + | U64 -> Printf.sprintf u_format 64 + | U128 -> Printf.sprintf u_format 128 + +(** Small helper to compute the name of a unary operation *) +let unop_name (unop : unop) : string = + match unop with + | Not -> ( + match !backend with FStar | Lean -> "not" | Coq -> "negb" | HOL4 -> "~") + | Neg (int_ty : integer_type) -> ( + match !backend with Lean -> "-" | _ -> int_name int_ty ^ "_neg") + | Cast _ -> + (* We never directly use the unop name in this case *) + raise (Failure "Unsupported") + +(** Small helper to compute the name of a binary operation (note that many + binary operations like "less than" are extracted to primitive operations, + like [<]). + *) +let named_binop_name (binop : E.binop) (int_ty : integer_type) : string = + let binop = + match binop with + | Div -> "div" + | Rem -> "rem" + | Add -> "add" + | Sub -> "sub" + | Mul -> "mul" + | Lt -> "lt" + | Le -> "le" + | Ge -> "ge" + | Gt -> "gt" + | BitXor -> "xor" + | BitAnd -> "and" + | BitOr -> "or" + | Shl -> "lsl" + | Shr -> + "asr" + (* NOTE: make sure arithmetic shift right is implemented, i.e. OCaml's asr operator, not lsr *) + | _ -> raise (Failure "Unreachable") + in + (* Remark: the Lean case is actually not used *) + match !backend with + | Lean -> int_name int_ty ^ "." ^ binop + | FStar | Coq | HOL4 -> int_name int_ty ^ "_" ^ binop + +(** A list of keywords/identifiers used by the backend and with which we + want to check collision. + + Remark: this is useful mostly to look for collisions when generating + names for *variables*. + *) +let keywords () = + let named_unops = + unop_name Not + :: List.map (fun it -> unop_name (Neg it)) T.all_signed_int_types + in + let named_binops = [ E.Div; Rem; Add; Sub; Mul ] in + let named_binops = + List.concat_map + (fun bn -> List.map (fun it -> named_binop_name bn it) T.all_int_types) + named_binops + in + let misc = + match !backend with + | FStar -> + [ + "assert"; + "assert_norm"; + "assume"; + "else"; + "fun"; + "fn"; + "FStar"; + "FStar.Mul"; + "if"; + "in"; + "include"; + "int"; + "let"; + "list"; + "match"; + "open"; + "rec"; + "scalar_cast"; + "then"; + "type"; + "Type0"; + "Type"; + "unit"; + "val"; + "with"; + ] + | Coq -> + [ + "assert"; + "Arguments"; + "Axiom"; + "char_of_byte"; + "Check"; + "Declare"; + "Definition"; + "else"; + "End"; + "fun"; + "Fixpoint"; + "if"; + "in"; + "int"; + "Inductive"; + "Import"; + "let"; + "Lemma"; + "match"; + "Module"; + "not"; + "Notation"; + "Proof"; + "Qed"; + "rec"; + "Record"; + "Require"; + "Scope"; + "Search"; + "SearchPattern"; + "Set"; + "then"; + (* [tt] is unit *) + "tt"; + "type"; + "Type"; + "unit"; + "with"; + ] + | Lean -> + [ + "by"; + "class"; + "decreasing_by"; + "def"; + "deriving"; + "do"; + "else"; + "end"; + "for"; + "have"; + "if"; + "inductive"; + "instance"; + "import"; + "let"; + "macro"; + "match"; + "namespace"; + "opaque"; + "open"; + "run_cmd"; + "set_option"; + "simp"; + "structure"; + "syntax"; + "termination_by"; + "then"; + "Type"; + "unsafe"; + "where"; + "with"; + "opaque_defs"; + ] + | HOL4 -> + [ + "Axiom"; + "case"; + "Definition"; + "else"; + "End"; + "fix"; + "fix_exec"; + "fn"; + "fun"; + "if"; + "in"; + "int"; + "Inductive"; + "let"; + "of"; + "Proof"; + "QED"; + "then"; + "Theorem"; + ] + in + List.concat [ named_unops; named_binops; misc ] + +let assumed_adts () : (assumed_ty * string) list = + match !backend with + | Lean -> + [ + (State, "State"); + (Result, "Result"); + (Error, "Error"); + (Fuel, "Nat"); + (Array, "Array"); + (Slice, "Slice"); + (Str, "Str"); + (RawPtr Mut, "MutRawPtr"); + (RawPtr Const, "ConstRawPtr"); + ] + | Coq | FStar | HOL4 -> + [ + (State, "state"); + (Result, "result"); + (Error, "error"); + (Fuel, if !backend = HOL4 then "num" else "nat"); + (Array, "array"); + (Slice, "slice"); + (Str, "str"); + (RawPtr Mut, "mut_raw_ptr"); + (RawPtr Const, "const_raw_ptr"); + ] + +let assumed_struct_constructors () : (assumed_ty * string) list = + match !backend with + | Lean -> [ (Array, "Array.make") ] + | Coq -> [ (Array, "mk_array") ] + | FStar -> [ (Array, "mk_array") ] + | HOL4 -> [ (Array, "mk_array") ] + +let assumed_variants () : (assumed_ty * VariantId.id * string) list = + match !backend with + | FStar -> + [ + (Result, result_return_id, "Return"); + (Result, result_fail_id, "Fail"); + (Error, error_failure_id, "Failure"); + (Error, error_out_of_fuel_id, "OutOfFuel"); + (* No Fuel::Zero on purpose *) + (* No Fuel::Succ on purpose *) + ] + | Coq -> + [ + (Result, result_return_id, "Return"); + (Result, result_fail_id, "Fail_"); + (Error, error_failure_id, "Failure"); + (Error, error_out_of_fuel_id, "OutOfFuel"); + (Fuel, fuel_zero_id, "O"); + (Fuel, fuel_succ_id, "S"); + ] + | Lean -> + [ + (Result, result_return_id, "ret"); + (Result, result_fail_id, "fail"); + (Error, error_failure_id, "panic"); + (* No Fuel::Zero on purpose *) + (* No Fuel::Succ on purpose *) + ] + | HOL4 -> + [ + (Result, result_return_id, "Return"); + (Result, result_fail_id, "Fail"); + (Error, error_failure_id, "Failure"); + (* No Fuel::Zero on purpose *) + (* No Fuel::Succ on purpose *) + ] + +let assumed_llbc_functions () : + (A.assumed_fun_id * T.RegionGroupId.id option * string) list = + let rg0 = Some T.RegionGroupId.zero in + match !backend with + | FStar | Coq | HOL4 -> + [ + (ArrayIndexShared, None, "array_index_usize"); + (ArrayIndexMut, None, "array_index_usize"); + (ArrayIndexMut, rg0, "array_update_usize"); + (ArrayToSliceShared, None, "array_to_slice"); + (ArrayToSliceMut, None, "array_to_slice"); + (ArrayToSliceMut, rg0, "array_from_slice"); + (ArrayRepeat, None, "array_repeat"); + (SliceIndexShared, None, "slice_index_usize"); + (SliceIndexMut, None, "slice_index_usize"); + (SliceIndexMut, rg0, "slice_update_usize"); + (SliceLen, None, "slice_len"); + ] + | Lean -> + [ + (ArrayIndexShared, None, "Array.index_usize"); + (ArrayIndexMut, None, "Array.index_usize"); + (ArrayIndexMut, rg0, "Array.update_usize"); + (ArrayToSliceShared, None, "Array.to_slice"); + (ArrayToSliceMut, None, "Array.to_slice"); + (ArrayToSliceMut, rg0, "Array.from_slice"); + (ArrayRepeat, None, "Array.repeat"); + (SliceIndexShared, None, "Slice.index_usize"); + (SliceIndexMut, None, "Slice.index_usize"); + (SliceIndexMut, rg0, "Slice.update_usize"); + (SliceLen, None, "Slice.len"); + ] + +let assumed_pure_functions () : (pure_assumed_fun_id * string) list = + match !backend with + | FStar -> + [ + (Return, "return"); + (Fail, "fail"); + (Assert, "massert"); + (FuelDecrease, "decrease"); + (FuelEqZero, "is_zero"); + ] + | Coq -> + (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) + [ (Return, "return_"); (Fail, "fail_"); (Assert, "massert") ] + | Lean -> + (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) + [ (Return, "return"); (Fail, "fail_"); (Assert, "massert") ] + | HOL4 -> + (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) + [ (Return, "return"); (Fail, "fail"); (Assert, "massert") ] + +let names_map_init () : names_map_init = + { + keywords = keywords (); + assumed_adts = assumed_adts (); + assumed_structs = assumed_struct_constructors (); + assumed_variants = assumed_variants (); + assumed_llbc_functions = assumed_llbc_functions (); + assumed_pure_functions = assumed_pure_functions (); + } + +let extract_unop (extract_expr : bool -> texpression -> unit) + (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit + = + match unop with + | Not | Neg _ -> + let unop = unop_name unop in + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt unop; + F.pp_print_space fmt (); + extract_expr true arg; + if inside then F.pp_print_string fmt ")" + | Cast (src, tgt) -> ( + (* HOL4 has a special treatment: because it doesn't support dependent + types, we don't have a specific operator for the cast *) + match !backend with + | HOL4 -> + (* Casting, say, an u32 to an i32 would be done as follows: + {[ + mk_i32 (u32_to_int x) + ]} + *) + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt ("mk_" ^ int_name tgt); + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + F.pp_print_string fmt (int_name src ^ "_to_int"); + F.pp_print_space fmt (); + extract_expr true arg; + F.pp_print_string fmt ")"; + if inside then F.pp_print_string fmt ")" + | FStar | Coq | Lean -> + (* Rem.: the source type is an implicit parameter *) + if inside then F.pp_print_string fmt "("; + let cast_str = + match !backend with + | Coq | FStar -> "scalar_cast" + | Lean -> (* TODO: I8.cast, I16.cast, etc.*) "Scalar.cast" + | HOL4 -> raise (Failure "Unreachable") + in + F.pp_print_string fmt cast_str; + F.pp_print_space fmt (); + if !backend <> Lean then ( + F.pp_print_string fmt + (StringUtils.capitalize_first_letter + (PrintPure.integer_type_to_string src)); + F.pp_print_space fmt ()); + if !backend = Lean then F.pp_print_string fmt ("." ^ int_name tgt) + else + F.pp_print_string fmt + (StringUtils.capitalize_first_letter + (PrintPure.integer_type_to_string tgt)); + F.pp_print_space fmt (); + extract_expr true arg; + if inside then F.pp_print_string fmt ")") + +(** [extract_expr] : the boolean argument is [inside] *) +let extract_binop (extract_expr : bool -> texpression -> unit) + (fmt : F.formatter) (inside : bool) (binop : E.binop) + (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = + if inside then F.pp_print_string fmt "("; + (* Some binary operations have a special notation depending on the backend *) + (match (!backend, binop) with + | HOL4, (Eq | Ne) + | (FStar | Coq | Lean), (Eq | Lt | Le | Ne | Ge | Gt) + | Lean, (Div | Rem | Add | Sub | Mul) -> + let binop = + match binop with + | Eq -> "=" + | Lt -> "<" + | Le -> "<=" + | Ne -> if !backend = Lean then "!=" else "<>" + | Ge -> ">=" + | Gt -> ">" + | Div -> "/" + | Rem -> "%" + | Add -> "+" + | Sub -> "-" + | Mul -> "*" + | _ -> raise (Failure "Unreachable") + in + let binop = + match !backend with FStar | Lean | HOL4 -> binop | Coq -> "s" ^ binop + in + extract_expr false arg0; + F.pp_print_space fmt (); + F.pp_print_string fmt binop; + F.pp_print_space fmt (); + extract_expr false arg1 + | _ -> + let binop = named_binop_name binop int_ty in + F.pp_print_string fmt binop; + F.pp_print_space fmt (); + extract_expr true arg0; + F.pp_print_space fmt (); + extract_expr true arg1); + if inside then F.pp_print_string fmt ")" + +let type_decl_kind_to_qualif (kind : decl_kind) + (type_kind : type_decl_kind option) : string option = + match !backend with + | FStar -> ( + match kind with + | SingleNonRec -> Some "type" + | SingleRec -> Some "type" + | MutRecFirst -> Some "type" + | MutRecInner -> Some "and" + | MutRecLast -> Some "and" + | Assumed -> Some "assume type" + | Declared -> Some "val") + | Coq -> ( + match (kind, type_kind) with + | SingleNonRec, Some Enum -> Some "Inductive" + | SingleNonRec, Some Struct -> Some "Record" + | (SingleRec | MutRecFirst), Some _ -> Some "Inductive" + | (MutRecInner | MutRecLast), Some _ -> + (* Coq doesn't support groups of mutually recursive definitions which mix + * records and inducties: we convert everything to records if this happens + *) + Some "with" + | (Assumed | Declared), None -> Some "Axiom" + | SingleNonRec, None -> + (* This is for traits *) + Some "Record" + | _ -> + raise + (Failure + ("Unexpected: (" ^ show_decl_kind kind ^ ", " + ^ Print.option_to_string show_type_decl_kind type_kind + ^ ")"))) + | Lean -> ( + match kind with + | SingleNonRec -> + if type_kind = Some Struct then Some "structure" else Some "inductive" + | SingleRec -> Some "inductive" + | MutRecFirst -> Some "inductive" + | MutRecInner -> Some "inductive" + | MutRecLast -> Some "inductive" + | Assumed -> Some "axiom" + | Declared -> Some "axiom") + | HOL4 -> None + +let fun_decl_kind_to_qualif (kind : decl_kind) : string option = + match !backend with + | FStar -> ( + match kind with + | SingleNonRec -> Some "let" + | SingleRec -> Some "let rec" + | MutRecFirst -> Some "let rec" + | MutRecInner -> Some "and" + | MutRecLast -> Some "and" + | Assumed -> Some "assume val" + | Declared -> Some "val") + | Coq -> ( + match kind with + | SingleNonRec -> Some "Definition" + | SingleRec -> Some "Fixpoint" + | MutRecFirst -> Some "Fixpoint" + | MutRecInner -> Some "with" + | MutRecLast -> Some "with" + | Assumed -> Some "Axiom" + | Declared -> Some "Axiom") + | Lean -> ( + match kind with + | SingleNonRec -> Some "def" + | SingleRec -> Some "divergent def" + | MutRecFirst -> Some "mutual divergent def" + | MutRecInner -> Some "divergent def" + | MutRecLast -> Some "divergent def" + | Assumed -> Some "axiom" + | Declared -> Some "axiom") + | HOL4 -> None + +(** The type of types. + + TODO: move inside the formatter? + *) +let type_keyword () = + match !backend with + | FStar -> "Type0" + | Coq | Lean -> "Type" + | HOL4 -> raise (Failure "Unexpected") + +(** + [ctx]: we use the context to lookup type definitions, to retrieve type names. + This is used to compute variable names, when they have no basenames: in this + case we use the first letter of the type name. + + [variant_concatenate_type_name]: if true, add the type name as a prefix + to the variant names. + Ex.: + In Rust: + {[ + enum List = { + Cons(u32, Box<List>),x + Nil, + } + ]} + + F*, if option activated: + {[ + type list = + | ListCons : u32 -> list -> list + | ListNil : list + ]} + + F*, if option not activated: + {[ + type list = + | Cons : u32 -> list -> list + | Nil : list + ]} + + Rk.: this should be true by default, because in Rust all the variant names + are actively uniquely identifier by the type name [List::Cons(...)], while + in other languages it is not necessarily the case, and thus clashes can mess + up type checking. Note that some languages actually forbids the name clashes + (it is the case of F* ). + *) +let mk_formatter (ctx : trans_ctx) (crate_name : string) + (variant_concatenate_type_name : bool) : formatter = + let int_name = int_name in + + (* Prepare a name. + * The first id elem is always the crate: if it is the local crate, + * we remove it. + * We also remove all the disambiguators, then convert everything to strings. + * **Rmk:** because we remove the disambiguators, there may be name collisions + * (which is ok, because we check for name collisions and fail if there is any). + *) + let get_name (name : name) : string list = + (* Rmk.: initially we only filtered the disambiguators equal to 0 *) + let name = Names.filter_disambiguators name in + match name with + | Ident crate :: name -> + let name = if crate = crate_name then name else Ident crate :: name in + let name = + List.map + (function + | Names.Ident s -> s + | Disambiguator d -> Names.Disambiguator.to_string d) + name + in + name + | _ -> + raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) + in + let flatten_name (name : string list) : string = + match !backend with + | FStar | Coq | HOL4 -> String.concat "_" name + | Lean -> String.concat "." name + in + let get_type_name = get_name in + let get_type_name_no_suffix name = + match !backend with + | FStar | Coq | HOL4 -> String.concat "_" (get_type_name name) + | Lean -> String.concat "." (get_type_name name) + in + let type_name name = + match !backend with + | FStar -> + StringUtils.lowercase_first_letter (get_type_name_no_suffix name ^ "_t") + | Coq | HOL4 -> get_type_name_no_suffix name ^ "_t" + | Lean -> get_type_name_no_suffix name + in + let field_name (def_name : name) (field_id : FieldId.id) + (field_name : string option) : string = + let field_name_s = + match field_name with + | Some field_name -> field_name + | None -> + (* TODO: extract structs with no field names to tuples *) + FieldId.to_string field_id + in + if !Config.record_fields_short_names then + if field_name = None then (* TODO: this is a bit ugly *) + "_" ^ field_name_s + else field_name_s + else + let def_name = get_type_name_no_suffix def_name ^ "_" ^ field_name_s in + match !backend with + | Lean | HOL4 -> def_name + | Coq | FStar -> StringUtils.lowercase_first_letter def_name + in + let variant_name (def_name : name) (variant : string) : string = + match !backend with + | FStar | Coq | HOL4 -> + let variant = to_camel_case variant in + if variant_concatenate_type_name then + StringUtils.capitalize_first_letter + (get_type_name_no_suffix def_name ^ "_" ^ variant) + else variant + | Lean -> variant + in + let struct_constructor (basename : name) : string = + let tname = type_name basename in + ExtractBuiltin.mk_struct_constructor tname + in + let get_fun_name fname = + let fname = get_name fname in + (* TODO: don't convert to snake case for Coq, HOL4, F* *) + let fname = flatten_name fname in + match !backend with + | FStar | Coq | HOL4 -> StringUtils.lowercase_first_letter fname + | Lean -> fname + in + let global_name (name : global_name) : string = + (* Converting to snake case also lowercases the letters (in Rust, global + * names are written in capital letters). *) + let parts = List.map to_snake_case (get_name name) in + String.concat "_" parts + in + let fun_name (fname : fun_name) (num_loops : int) (loop_id : LoopId.id option) + (num_rgs : int) (rg : region_group_info option) (filter_info : bool * int) + : string = + let fname = get_fun_name fname in + (* Compute the suffix *) + let suffix = default_fun_suffix num_loops loop_id num_rgs rg filter_info in + (* Concatenate *) + fname ^ suffix + in + + let trait_decl_name (trait_decl : trait_decl) : string = + type_name trait_decl.name + in + + let trait_impl_name (trait_decl : trait_decl) (trait_impl : trait_impl) : + string = + (* TODO: provisional: we concatenate the trait impl name (which is its type) + with the trait decl name *) + let trait_decl = + let name = trait_decl.name in + let name = get_type_name_no_suffix name ^ "Inst" in + (* Remove the occurrences of '.' *) + String.concat "" (String.split_on_char '.' name) + in + let name = flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) in + match !backend with + | FStar -> StringUtils.lowercase_first_letter name + | Coq | HOL4 | Lean -> name + in + + let trait_decl_constructor (trait_decl : trait_decl) : string = + let name = trait_decl_name trait_decl in + ExtractBuiltin.mk_struct_constructor name + in + + let trait_parent_clause_name (trait_decl : trait_decl) (clause : trait_clause) + : string = + (* TODO: improve - it would be better to not use indices *) + let clause = "parent_clause_" ^ TraitClauseId.to_string clause.clause_id in + if !Config.record_fields_short_names then clause + else trait_decl_name trait_decl ^ "_" ^ clause + in + let trait_type_name (trait_decl : trait_decl) (item : string) : string = + let name = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + (* Constants are usually all capital letters. + Some backends do not support field names starting with a capital letter, + and it may be weird to lowercase everything (especially as it may lead + to more name collisions): we add a prefix when necessary. + For instance, it gives: "U" -> "tU" + Note that for some backends we prepend the type name (because those backends + can't disambiguate fields coming from different ADTs if they have the same + names), and thus don't need to add a prefix starting with a lowercase. + *) + match !backend with FStar -> "t" ^ name | Coq | Lean | HOL4 -> name + in + let trait_const_name (trait_decl : trait_decl) (item : string) : string = + let name = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + (* See [trait_type_name] *) + match !backend with FStar -> "c" ^ name | Coq | Lean | HOL4 -> name + in + let trait_method_name (trait_decl : trait_decl) (item : string) : string = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + let trait_type_clause_name (trait_decl : trait_decl) (item : string) + (clause : trait_clause) : string = + (* TODO: improve - it would be better to not use indices *) + trait_type_name trait_decl item + ^ "_clause_" + ^ TraitClauseId.to_string clause.clause_id + in + + let termination_measure_name (_fid : A.FunDeclId.id) (fname : fun_name) + (num_loops : int) (loop_id : LoopId.id option) : string = + let fname = get_fun_name fname in + let lp_suffix = default_fun_loop_suffix num_loops loop_id in + (* Compute the suffix *) + let suffix = + match !Config.backend with + | FStar -> "_decreases" + | Lean -> "_terminates" + | Coq | HOL4 -> raise (Failure "Unexpected") + in + (* Concatenate *) + fname ^ lp_suffix ^ suffix + in + + let decreases_proof_name (_fid : A.FunDeclId.id) (fname : fun_name) + (num_loops : int) (loop_id : LoopId.id option) : string = + let fname = get_fun_name fname in + let lp_suffix = default_fun_loop_suffix num_loops loop_id in + (* Compute the suffix *) + let suffix = + match !Config.backend with + | Lean -> "_decreases" + | FStar | Coq | HOL4 -> raise (Failure "Unexpected") + in + (* Concatenate *) + fname ^ lp_suffix ^ suffix + in + + let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) + : string = + (* Small helper to derive var names from ADT type names. + + We do the following: + - convert the type name to snake case + - take the first letter of every "letter group" + Ex.: "HashMap" -> "hash_map" -> "hm" + *) + let name_from_type_ident (name : string) : string = + let cl = to_snake_case name in + let cl = String.split_on_char '_' cl in + let cl = List.filter (fun s -> String.length s > 0) cl in + assert (List.length cl > 0); + let cl = List.map (fun s -> s.[0]) cl in + StringUtils.string_of_chars cl + in + (* If there is a basename, we use it *) + match basename with + | Some basename -> + (* This should be a no-op *) + to_snake_case basename + | None -> ( + (* No basename: we use the first letter of the type *) + match ty with + | Adt (type_id, generics) -> ( + match type_id with + | Tuple -> + (* The "pair" case is frequent enough to have its special treatment *) + if List.length generics.types = 2 then "p" else "t" + | Assumed Result -> "r" + | Assumed Error -> ConstStrings.error_basename + | Assumed Fuel -> ConstStrings.fuel_basename + | Assumed Array -> "a" + | Assumed Slice -> "s" + | Assumed Str -> "s" + | Assumed State -> ConstStrings.state_basename + | Assumed (RawPtr _) -> "p" + | AdtId adt_id -> + let def = TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in + (* Derive the var name from the last ident of the type name + * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" + *) + (* The name shouldn't be empty, and its last element should + * be an ident *) + let cl = List.nth def.name (List.length def.name - 1) in + name_from_type_ident (Names.as_ident cl)) + | TypeVar _ -> ( + (* TODO: use "t" also for F* *) + match !backend with + | FStar -> "x" (* lacking inspiration here... *) + | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) + | Literal lty -> ( + match lty with Bool -> "b" | Char -> "c" | Integer _ -> "i") + | Arrow _ -> "f" + | TraitType (_, _, name) -> name_from_type_ident name) + in + let type_var_basename (_varset : StringSet.t) (basename : string) : string = + (* Rust type variables are snake-case and start with a capital letter *) + match !backend with + | FStar -> + (* This is *not* a no-op: this removes the capital letter *) + to_snake_case basename + | HOL4 -> + (* In HOL4, type variable names must start with "'" *) + "'" ^ to_snake_case basename + | Coq | Lean -> basename + in + let const_generic_var_basename (_varset : StringSet.t) (basename : string) : + string = + (* Rust type variables are snake-case and start with a capital letter *) + match !backend with + | FStar | HOL4 -> + (* This is *not* a no-op: this removes the capital letter *) + to_snake_case basename + | Coq | Lean -> basename + in + let trait_clause_basename (_varset : StringSet.t) (_clause : trait_clause) : + string = + (* TODO: actually use the clause to derive the name *) + "inst" + in + let trait_self_clause_basename = "self_clause" in + let append_index (basename : string) (i : int) : string = + basename ^ string_of_int i + in + + let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit + = + match cv with + | Scalar sv -> ( + match !backend with + | FStar -> F.pp_print_string fmt (Z.to_string sv.PV.value) + | Coq | HOL4 | Lean -> + let print_brackets = inside && !backend = HOL4 in + if print_brackets then F.pp_print_string fmt "("; + (match !backend with + | Coq | Lean -> () + | HOL4 -> + F.pp_print_string fmt ("int_to_" ^ int_name sv.PV.int_ty); + F.pp_print_space fmt () + | _ -> raise (Failure "Unreachable")); + (* We need to add parentheses if the value is negative *) + if sv.PV.value >= Z.of_int 0 then + F.pp_print_string fmt (Z.to_string sv.PV.value) + else if !backend = Lean then + (* TODO: parsing issues with Lean because there are ambiguous + interpretations between int values and nat values *) + F.pp_print_string fmt + ("(-(" ^ Z.to_string (Z.neg sv.PV.value) ^ ":Int))") + else F.pp_print_string fmt ("(" ^ Z.to_string sv.PV.value ^ ")"); + (match !backend with + | Coq -> + let iname = int_name sv.PV.int_ty in + F.pp_print_string fmt ("%" ^ iname) + | Lean -> + let iname = String.lowercase_ascii (int_name sv.PV.int_ty) in + F.pp_print_string fmt ("#" ^ iname) + | HOL4 -> () + | _ -> raise (Failure "Unreachable")); + if print_brackets then F.pp_print_string fmt ")") + | Bool b -> + let b = + match !backend with + | HOL4 -> if b then "T" else "F" + | Coq | FStar | Lean -> if b then "true" else "false" + in + F.pp_print_string fmt b + | Char c -> ( + match !backend with + | HOL4 -> + (* [#"a"] is a notation for [CHR 97] (97 is the ASCII code for 'a') *) + F.pp_print_string fmt ("#\"" ^ String.make 1 c ^ "\"") + | FStar | Lean -> F.pp_print_string fmt ("'" ^ String.make 1 c ^ "'") + | Coq -> + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt "char_of_byte"; + F.pp_print_space fmt (); + (* Convert the the char to ascii *) + let c = + let i = Char.code c in + let x0 = i / 16 in + let x1 = i mod 16 in + "Coq.Init.Byte.x" ^ string_of_int x0 ^ string_of_int x1 + in + F.pp_print_string fmt c; + if inside then F.pp_print_string fmt ")") + in + let bool_name = if !backend = Lean then "Bool" else "bool" in + let char_name = if !backend = Lean then "Char" else "char" in + let str_name = if !backend = Lean then "String" else "string" in + { + bool_name; + char_name; + int_name; + str_name; + type_decl_kind_to_qualif; + fun_decl_kind_to_qualif; + field_name; + variant_name; + struct_constructor; + type_name; + global_name; + fun_name; + termination_measure_name; + decreases_proof_name; + trait_decl_name; + trait_impl_name; + trait_decl_constructor; + trait_parent_clause_name; + trait_const_name; + trait_type_name; + trait_method_name; + trait_type_clause_name; + var_basename; + type_var_basename; + const_generic_var_basename; + trait_self_clause_basename; + trait_clause_basename; + append_index; + extract_literal; + extract_unop; + extract_binop; + } + +let mk_formatter_and_names_maps (ctx : trans_ctx) (crate_name : string) + (variant_concatenate_type_name : bool) : formatter * names_maps = + let fmt = mk_formatter ctx crate_name variant_concatenate_type_name in + let names_maps = initialize_names_maps fmt (names_map_init ()) in + (fmt, names_maps) + +let is_single_opaque_fun_decl_group (dg : Pure.fun_decl list) : bool = + match dg with [ d ] -> d.body = None | _ -> false + +let is_single_opaque_type_decl_group (dg : Pure.type_decl list) : bool = + match dg with [ d ] -> d.kind = Opaque | _ -> false + +let is_empty_record_type_decl (d : Pure.type_decl) : bool = d.kind = Struct [] + +let is_empty_record_type_decl_group (dg : Pure.type_decl list) : bool = + match dg with [ d ] -> is_empty_record_type_decl d | _ -> false + +(** In some provers, groups of definitions must be delimited. + + - in Coq, *every* group (including singletons) must end with "." + - in Lean, groups of mutually recursive definitions must end with "end" + - in HOL4 (in most situations) the whole group must be within a `Define` command + + Calls to {!extract_fun_decl} should be inserted between calls to + {!start_fun_decl_group} and {!end_fun_decl_group}. + + TODO: maybe those [{start/end}_decl_group] functions are not that much a good + idea and we should merge them with the corresponding [extract_decl] functions. + *) +let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) + (is_rec : bool) (dg : Pure.fun_decl list) = + match !backend with + | FStar | Coq | Lean -> () + | HOL4 -> + (* In HOL4, opaque functions have a special treatment *) + if is_single_opaque_fun_decl_group dg then () + else + let compute_fun_def_name (def : Pure.fun_decl) : string = + ctx_get_local_function def.def_id def.loop_id def.back_id ctx ^ "_def" + in + let names = List.map compute_fun_def_name dg in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Open the box for the delimiters *) + F.pp_open_vbox fmt 0; + (* Open the box for the definitions themselves *) + F.pp_open_vbox fmt ctx.indent_incr; + (* Print the delimiters *) + if is_rec then + F.pp_print_string fmt + ("val [" ^ String.concat ", " names ^ "] = DefineDiv ‘") + else ( + assert (List.length names = 1); + let name = List.hd names in + F.pp_print_string fmt ("val " ^ name ^ " = Define ‘")); + F.pp_print_cut fmt () + +(** See {!start_fun_decl_group}. *) +let end_fun_decl_group (fmt : F.formatter) (is_rec : bool) + (dg : Pure.fun_decl list) = + match !backend with + | FStar -> () + | Coq -> + (* For aesthetic reasons, we print the Coq end group delimiter directly + in {!extract_fun_decl}. *) + () + | Lean -> + (* We must add the "end" keyword to groups of mutually recursive functions *) + if is_rec && List.length dg > 1 then ( + F.pp_print_cut fmt (); + F.pp_print_string fmt "end"; + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0) + else () + | HOL4 -> + (* In HOL4, opaque functions have a special treatment *) + if is_single_opaque_fun_decl_group dg then () + else ( + (* Close the box for the definitions *) + F.pp_close_box fmt (); + (* Print the end delimiter *) + F.pp_print_cut fmt (); + F.pp_print_string fmt "’"; + (* Close the box for the delimiters *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0) + +(** See {!start_fun_decl_group}: similar usage, but for the type declarations. *) +let start_type_decl_group (ctx : extraction_ctx) (fmt : F.formatter) + (is_rec : bool) (dg : Pure.type_decl list) = + match !backend with + | FStar | Coq -> () + | Lean -> + if is_rec && List.length dg > 1 then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "mutual"; + F.pp_print_space fmt ()) + | HOL4 -> + (* In HOL4, opaque types and empty records have a special treatment *) + if + is_single_opaque_type_decl_group dg + || is_empty_record_type_decl_group dg + then () + else ( + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Open the box for the delimiters *) + F.pp_open_vbox fmt 0; + (* Open the box for the definitions themselves *) + F.pp_open_vbox fmt ctx.indent_incr; + (* Print the delimiters *) + F.pp_print_string fmt "Datatype:"; + F.pp_print_cut fmt ()) + +(** See {!start_fun_decl_group}. *) +let end_type_decl_group (fmt : F.formatter) (is_rec : bool) + (dg : Pure.type_decl list) = + match !backend with + | FStar -> () + | Coq -> + (* For aesthetic reasons, we print the Coq end group delimiter directly + in {!extract_fun_decl}. *) + () + | Lean -> + (* We must add the "end" keyword to groups of mutually recursive functions *) + if is_rec && List.length dg > 1 then ( + F.pp_print_cut fmt (); + F.pp_print_string fmt "end"; + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0) + else () + | HOL4 -> + (* In HOL4, opaque types and empty records have a special treatment *) + if + is_single_opaque_type_decl_group dg + || is_empty_record_type_decl_group dg + then () + else ( + (* Close the box for the definitions *) + F.pp_close_box fmt (); + (* Print the end delimiter *) + F.pp_print_cut fmt (); + F.pp_print_string fmt "End"; + (* Close the box for the delimiters *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0) + +let unit_name () = + match !backend with Lean -> "Unit" | Coq | FStar | HOL4 -> "unit" + +(** Small helper *) +let extract_arrow (fmt : F.formatter) () : unit = + if !Config.backend = Lean then F.pp_print_string fmt "→" + else F.pp_print_string fmt "->" + +let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (cg : const_generic) : unit = + match cg with + | ConstGenericGlobal id -> + let s = ctx_get_global id ctx in + F.pp_print_string fmt s + | ConstGenericValue v -> ctx.fmt.extract_literal fmt inside v + | ConstGenericVar id -> + let s = ctx_get_const_generic_var id ctx in + F.pp_print_string fmt s + +let extract_literal_type (ctx : extraction_ctx) (fmt : F.formatter) + (ty : literal_type) : unit = + match ty with + | Bool -> F.pp_print_string fmt ctx.fmt.bool_name + | Char -> F.pp_print_string fmt ctx.fmt.char_name + | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) + +(** [inside] constrols whether we should add parentheses or not around type + applications (if [true] we add parentheses). + + [no_params_tys]: for all the types inside this set, do not print the type parameters. + This is used for HOL4. As polymorphism is uniform in HOL4, printing the + type parameters in the recursive definitions is useless (and actually + forbidden). + + For instance, where in F* we would write: + {[ + type list a = | Nil : list a | Cons : a -> list a -> list a + ]} + + In HOL4 we would simply write: + {[ + Datatype: + list = Nil 'a | Cons 'a list + End + ]} + *) +let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (inside : bool) (ty : ty) : unit = + let extract_rec = extract_ty ctx fmt no_params_tys in + match ty with + | Adt (type_id, generics) -> ( + let has_params = generics <> empty_generic_args in + match type_id with + | Tuple -> + (* This is a bit annoying, but in F*/Coq/HOL4 [()] is not the unit type: + * we have to write [unit]... *) + if generics.types = [] then F.pp_print_string fmt (unit_name ()) + else ( + F.pp_print_string fmt "("; + Collections.List.iter_link + (fun () -> + F.pp_print_space fmt (); + let product = + match !backend with + | FStar -> "&" + | Coq -> "*" + | Lean -> "×" + | HOL4 -> "#" + in + F.pp_print_string fmt product; + F.pp_print_space fmt ()) + (extract_rec true) generics.types; + F.pp_print_string fmt ")") + | AdtId _ | Assumed _ -> ( + (* HOL4 behaves differently. Where in Coq/FStar/Lean we would write: + `tree a b` + + In HOL4 we would write: + `('a, 'b) tree` + *) + match !backend with + | FStar | Coq | Lean -> + let print_paren = inside && has_params in + if print_paren then F.pp_print_string fmt "("; + (* TODO: for now, only the opaque *functions* are extracted in the + opaque module. The opaque *types* are assumed. *) + F.pp_print_string fmt (ctx_get_type type_id ctx); + (* We might need to filter the type arguments, if the type + is builtin (for instance, we filter the global allocator type + argument for `Vec`). *) + let generics = + match type_id with + | AdtId id -> ( + match + TypeDeclId.Map.find_opt id ctx.types_filter_type_args_map + with + | None -> generics + | Some filter -> + let types = List.combine filter generics.types in + let types = + List.filter_map + (fun (b, ty) -> if b then Some ty else None) + types + in + { generics with types }) + | _ -> generics + in + extract_generic_args ctx fmt no_params_tys generics; + if print_paren then F.pp_print_string fmt ")" + | HOL4 -> + let { types; const_generics; trait_refs } = generics in + (* Const generics are not supported in HOL4 *) + assert (const_generics = []); + let print_tys = + match type_id with + | AdtId id -> not (TypeDeclId.Set.mem id no_params_tys) + | Assumed _ -> true + | _ -> raise (Failure "Unreachable") + in + if types <> [] && print_tys then ( + let print_paren = List.length types > 1 in + if print_paren then F.pp_print_string fmt "("; + Collections.List.iter_link + (fun () -> + F.pp_print_string fmt ","; + F.pp_print_space fmt ()) + (extract_rec true) types; + if print_paren then F.pp_print_string fmt ")"; + F.pp_print_space fmt ()); + F.pp_print_string fmt (ctx_get_type type_id ctx); + if trait_refs <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_trait_ref ctx fmt no_params_tys true) + trait_refs))) + | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) + | Literal lty -> extract_literal_type ctx fmt lty + | Arrow (arg_ty, ret_ty) -> + if inside then F.pp_print_string fmt "("; + extract_rec false arg_ty; + F.pp_print_space fmt (); + extract_arrow fmt (); + F.pp_print_space fmt (); + extract_rec false ret_ty; + if inside then F.pp_print_string fmt ")" + | TraitType (trait_ref, generics, type_name) -> ( + if !parameterize_trait_types then raise (Failure "Unimplemented") + else + let type_name = + ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name + ctx + in + let add_brackets (s : string) = + if !backend = Coq then "(" ^ s ^ ")" else s + in + (* There may be a special treatment depending on the instance id. + See the comments for {!extract_trait_instance_id_with_dot}. + TODO: there should be a cleaner way to do. The annoying thing + here is that if we project directly over the self clause, then + we have to be careful (we may not have to print the "Self."). + Otherwise, we can directly call {!extract_trait_ref}. + *) + match trait_ref.trait_id with + | Self -> + assert (generics = empty_generic_args); + assert (trait_ref.generics = empty_generic_args); + extract_trait_instance_id_with_dot ctx fmt no_params_tys false + trait_ref.trait_id; + F.pp_print_string fmt type_name + | _ -> + (* HOL4 doesn't have 1st class types *) + assert (!backend <> HOL4); + let use_brackets = generics <> empty_generic_args in + if use_brackets then F.pp_print_string fmt "("; + extract_trait_ref ctx fmt no_params_tys false trait_ref; + extract_generic_args ctx fmt no_params_tys generics; + if use_brackets then F.pp_print_string fmt ")"; + F.pp_print_string fmt ("." ^ add_brackets type_name)) + +and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = + let use_brackets = tr.generics <> empty_generic_args && inside in + if use_brackets then F.pp_print_string fmt "("; + (* We may need to filter the parameters if the trait is builtin *) + let generics = + match tr.trait_id with + | TraitImpl id -> ( + match + TraitImplId.Map.find_opt id ctx.trait_impls_filter_type_args_map + with + | None -> tr.generics + | Some filter -> + let types = + List.filter_map + (fun (b, x) -> if b then Some x else None) + (List.combine filter tr.generics.types) + in + { tr.generics with types }) + | _ -> tr.generics + in + extract_trait_instance_id ctx fmt no_params_tys inside tr.trait_id; + extract_generic_args ctx fmt no_params_tys generics; + if use_brackets then F.pp_print_string fmt ")" + +and extract_trait_decl_ref (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_decl_ref) : + unit = + let use_brackets = tr.decl_generics <> empty_generic_args && inside in + let name = ctx_get_trait_decl tr.trait_decl_id ctx in + if use_brackets then F.pp_print_string fmt "("; + F.pp_print_string fmt name; + (* There is something subtle here: the trait obligations for the implemented + trait are put inside the parent clauses, so we must ignore them here *) + let generics = { tr.decl_generics with trait_refs = [] } in + extract_generic_args ctx fmt no_params_tys generics; + if use_brackets then F.pp_print_string fmt ")" + +and extract_generic_args (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (generics : generic_args) : unit = + let { types; const_generics; trait_refs } = generics in + if !backend <> HOL4 then ( + if types <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_ty ctx fmt no_params_tys true) + types); + if const_generics <> [] then ( + assert (!backend <> HOL4); + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_const_generic ctx fmt true) + const_generics)); + if trait_refs <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_trait_ref ctx fmt no_params_tys true) + trait_refs) + +(** We sometimes need to ignore references to `Self` when generating the + code, espcially when we project associated items. For this reason we + have a special function for the cases where we project from an instance + id (e.g., `<Self as Foo>::foo` - note that in the extracted code, the + projections are often written with a dot '.'). + *) +and extract_trait_instance_id_with_dot (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) + (id : trait_instance_id) : unit = + match id with + | Self -> + (* There are two situations: + - we are extracting a declared item and need to refer to another + item (for instance, we are extracting a method signature and + need to refer to an associated type). + We directly refer to the other item (we extract trait declarations + as structures, so we can refer to their fields) + - we are extracting a provided method for a trait declaration. We + refer to the item in the self trait clause (see {!SelfTraitClauseId}). + + Remark: we can't get there for trait *implementations* because then the + types should have been normalized. + *) + if ctx.is_provided_method then + (* Provided method: use the trait self clause *) + let self_clause = ctx_get_trait_self_clause ctx in + F.pp_print_string fmt (self_clause ^ ".") + else + (* Declaration: nothing to print, we will directly refer to + the item. *) + () + | _ -> + (* Other cases *) + extract_trait_instance_id ctx fmt no_params_tys inside id; + F.pp_print_string fmt "." + +and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) + : unit = + let add_brackets (s : string) = if !backend = Coq then "(" ^ s ^ ")" else s in + match id with + | Self -> + (* This has a specific treatment depending on the item we're extracting + (associated type, etc.). We should have caught this elsewhere. *) + if !Config.fail_hard then + raise (Failure "Unexpected occurrence of `Self`") + else F.pp_print_string fmt "ERROR(\"Unexpected Self\")" + | TraitImpl id -> + let name = ctx_get_trait_impl id ctx in + F.pp_print_string fmt name + | Clause id -> + let name = ctx_get_local_trait_clause id ctx in + F.pp_print_string fmt name + | ParentClause (inst_id, decl_id, clause_id) -> + (* Use the trait decl id to lookup the name *) + let name = ctx_get_trait_parent_clause decl_id clause_id ctx in + extract_trait_instance_id_with_dot ctx fmt no_params_tys true inst_id; + F.pp_print_string fmt (add_brackets name) + | ItemClause (inst_id, decl_id, item_name, clause_id) -> + (* Use the trait decl id to lookup the name *) + let name = ctx_get_trait_item_clause decl_id item_name clause_id ctx in + extract_trait_instance_id_with_dot ctx fmt no_params_tys true inst_id; + F.pp_print_string fmt (add_brackets name) + | TraitRef trait_ref -> + extract_trait_ref ctx fmt no_params_tys inside trait_ref + | UnknownTrait _ -> + (* This is an error case *) + raise (Failure "Unexpected") + +(** Compute the names for all the top-level identifiers used in a type + definition (type name, variant names, field names, etc. but not type + parameters). + + We need to do this preemptively, beforce extracting any definition, + because of recursive definitions. + *) +let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : + extraction_ctx = + (* Lookup the builtin information, if there is *) + let open ExtractBuiltin in + let sname = name_to_simple_name def.name in + let info = SimpleNameMap.find_opt sname (builtin_types_map ()) in + (* Register the filtering information, if there is *) + let ctx = + match info with + | Some { keep_params = Some keep; _ } -> + { + ctx with + types_filter_type_args_map = + TypeDeclId.Map.add def.def_id keep ctx.types_filter_type_args_map; + } + | _ -> ctx + in + (* Compute and register the type def name *) + let def_name = + match info with + | None -> ctx.fmt.type_name def.name + | Some info -> info.extract_name + in + let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in + (* Compute and register: + * - the variant names, if this is an enumeration + * - the field names, if this is a structure + *) + let ctx = + match def.kind with + | Struct fields -> + (* Compute the names *) + let field_names, cons_name = + match info with + | None | Some { body_info = None; _ } -> + let field_names = + FieldId.mapi + (fun fid (field : field) -> + (fid, ctx.fmt.field_name def.name fid field.field_name)) + fields + in + let cons_name = ctx.fmt.struct_constructor def.name in + (field_names, cons_name) + | Some { body_info = Some (Struct (cons_name, field_names)); _ } -> + let field_names = + FieldId.mapi + (fun fid (field : field) -> + let rust_name = Option.get field.field_name in + let name = + snd (List.find (fun (n, _) -> n = rust_name) field_names) + in + (fid, name)) + fields + in + (field_names, cons_name) + | Some info -> + raise + (Failure + ("Invalid builtin information: " + ^ show_builtin_type_info info)) + in + (* Add the fields *) + let ctx = + List.fold_left + (fun ctx (fid, name) -> + ctx_add (FieldId (AdtId def.def_id, fid)) name ctx) + ctx field_names + in + (* Add the constructor name *) + ctx_add (StructId (AdtId def.def_id)) cons_name ctx + | Enum variants -> + let variant_names = + match info with + | None -> + VariantId.mapi + (fun variant_id (variant : variant) -> + let name = + ctx.fmt.variant_name def.name variant.variant_name + in + (* Add the type name prefix for Lean *) + let name = + if !Config.backend = Lean then + let type_name = ctx.fmt.type_name def.name in + type_name ^ "." ^ name + else name + in + (variant_id, name)) + variants + | Some { body_info = Some (Enum variant_infos); _ } -> + (* We need to compute the map from variant to variant *) + let variant_map = + StringMap.of_list + (List.map + (fun (info : builtin_enum_variant_info) -> + (info.rust_variant_name, info.extract_variant_name)) + variant_infos) + in + VariantId.mapi + (fun variant_id (variant : variant) -> + (variant_id, StringMap.find variant.variant_name variant_map)) + variants + | _ -> raise (Failure "Invalid builtin information") + in + List.fold_left + (fun ctx (vid, vname) -> + ctx_add (VariantId (AdtId def.def_id, vid)) vname ctx) + ctx variant_names + | Opaque -> + (* Nothing to do *) + ctx + in + (* Return *) + ctx + +(** Print the variants *) +let extract_type_decl_variant (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (type_name : string) + (type_params : string list) (cg_params : string list) (cons_name : string) + (fields : field list) : unit = + F.pp_print_space fmt (); + (* variant box *) + F.pp_open_hvbox fmt ctx.indent_incr; + (* [| Cons :] + * Note that we really don't want any break above so we print everything + * at once. *) + let opt_colon = if !backend <> HOL4 then " :" else "" in + F.pp_print_string fmt ("| " ^ cons_name ^ opt_colon); + let print_field (fid : FieldId.id) (f : field) (ctx : extraction_ctx) : + extraction_ctx = + F.pp_print_space fmt (); + (* Open the field box *) + F.pp_open_box fmt ctx.indent_incr; + (* Print the field names, if the backend accepts it. + * [ x :] + * Note that when printing fields, we register the field names as + * *variables*: they don't need to be unique at the top level. *) + let ctx = + match !backend with + | FStar -> ( + match f.field_name with + | None -> ctx + | Some field_name -> + let var_id = VarId.of_int (FieldId.to_int fid) in + let field_name = + ctx.fmt.var_basename ctx.names_maps.names_map.names_set + (Some field_name) f.field_ty + in + let ctx, field_name = ctx_add_var field_name var_id ctx in + F.pp_print_string fmt (field_name ^ " :"); + F.pp_print_space fmt (); + ctx) + | Coq | Lean | HOL4 -> ctx + in + (* Print the field type *) + let inside = !backend = HOL4 in + extract_ty ctx fmt type_decl_group inside f.field_ty; + (* Print the arrow [->] *) + if !backend <> HOL4 then ( + F.pp_print_space fmt (); + extract_arrow fmt ()); + (* Close the field box *) + F.pp_close_box fmt (); + (* Return *) + ctx + in + (* Print the fields *) + let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in + let _ = + List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields + in + (* Sanity check: HOL4 doesn't support const generics *) + assert (cg_params = [] || !backend <> HOL4); + (* Print the final type *) + if !backend <> HOL4 then ( + F.pp_print_space fmt (); + F.pp_open_hovbox fmt 0; + F.pp_print_string fmt type_name; + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + (List.append type_params cg_params); + F.pp_close_box fmt ()); + (* Close the variant box *) + F.pp_close_box fmt () + +(* TODO: we don' need the [def_name] paramter: it can be retrieved from the context *) +let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (def : type_decl) (def_name : string) + (type_params : string list) (cg_params : string list) + (variants : variant list) : unit = + (* We want to generate a definition which looks like this (taking F* as example): + {[ + type list a = | Cons : a -> list a -> list a | Nil : list a + ]} + + If there isn't enough space on one line: + {[ + type s = + | Cons : a -> list a -> list a + | Nil : list a + ]} + + And if we need to write the type of a variant on several lines: + {[ + type s = + | Cons : + a -> + list a -> + list a + | Nil : list a + ]} + + Finally, it is possible to give names to the variant fields in Rust. + In this situation, we generate a definition like this: + {[ + type s = + | Cons : hd:a -> tl:list a -> list a + | Nil : list a + ]} + + Note that we already printed: [type s =] + *) + let print_variant _variant_id (v : variant) = + (* We don't lookup the name, because it may have a prefix for the type + id (in the case of Lean) *) + let cons_name = ctx.fmt.variant_name def.name v.variant_name in + let fields = v.fields in + extract_type_decl_variant ctx fmt type_decl_group def_name type_params + cg_params cons_name fields + in + (* Print the variants *) + let variants = VariantId.mapi (fun vid v -> (vid, v)) variants in + List.iter (fun (vid, v) -> print_variant vid v) variants + +let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) + (type_params : string list) (cg_params : string list) (fields : field list) + : unit = + (* We want to generate a definition which looks like this (taking F* as example): + {[ + type t = { x : int; y : bool; } + ]} + + If there isn't enough space on one line: + {[ + type t = + { + x : int; y : bool; + } + ]} + + And if there is even less space: + {[ + type t = + { + x : int; + y : bool; + } + ]} + + Also, in case there are no fields, we need to define the type as [unit] + ([type t = {}] doesn't work in F* ). + + Coq: + ==== + We need to define the constructor name upon defining the struct (record, in Coq). + The syntex is: + {[ + Record Foo = mkFoo { x : int; y : bool; }. + }] + + Also, Coq doesn't support groups of mutually recursive inductives and records. + This is fine, because we can then define records as inductives, and leverage + the fact that when record fields are accessed, the records are symbolically + expanded which introduces let bindings of the form: [let RecordCons ... = x in ...]. + As a consequence, we never use the record projectors (unless we reconstruct + them in the micro passes of course). + + HOL4: + ===== + Type definitions are written as follows: + {[ + Datatype: + tree = + TLeaf 'a + | TNode node ; + + node = + Node (tree list) + End + ]} + *) + (* Note that we already printed: [type t =] *) + let is_rec = decl_is_from_rec_group kind in + let _ = + if !backend = FStar && fields = [] then ( + F.pp_print_space fmt (); + F.pp_print_string fmt (unit_name ())) + else if !backend = Lean && fields = [] then () + (* If the definition is recursive, we may need to extract it as an inductive + (instead of a record). We start with the "normal" case: we extract it + as a record. *) + else if (not is_rec) || (!backend <> Coq && !backend <> Lean) then ( + if !backend <> Lean then F.pp_print_space fmt (); + (* If Coq: print the constructor name *) + (* TODO: remove superfluous test not is_rec below *) + if !backend = Coq && not is_rec then ( + F.pp_print_string fmt (ctx_get_struct (AdtId def.def_id) ctx); + F.pp_print_string fmt " "); + (match !backend with + | Lean -> () + | FStar | Coq -> F.pp_print_string fmt "{" + | HOL4 -> F.pp_print_string fmt "<|"); + F.pp_print_break fmt 1 ctx.indent_incr; + (* The body itself *) + (* Open a box for the body *) + (match !backend with + | Coq | FStar | HOL4 -> F.pp_open_hvbox fmt 0 + | Lean -> F.pp_open_vbox fmt 0); + (* Print the fields *) + let print_field (field_id : FieldId.id) (f : field) : unit = + let field_name = ctx_get_field (AdtId def.def_id) field_id ctx in + (* Open a box for the field *) + F.pp_open_box fmt ctx.indent_incr; + F.pp_print_string fmt field_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_ty ctx fmt type_decl_group false f.field_ty; + if !backend <> Lean then F.pp_print_string fmt ";"; + (* Close the box for the field *) + F.pp_close_box fmt () + in + let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in + Collections.List.iter_link (F.pp_print_space fmt) + (fun (fid, f) -> print_field fid f) + fields; + (* Close the box for the body *) + F.pp_close_box fmt (); + match !backend with + | Lean -> () + | FStar | Coq -> + F.pp_print_space fmt (); + F.pp_print_string fmt "}" + | HOL4 -> + F.pp_print_space fmt (); + F.pp_print_string fmt "|>") + else ( + (* We extract for Coq or Lean, and we have a recursive record, or a record in + a group of mutually recursive types: we extract it as an inductive type *) + assert (is_rec && (!backend = Coq || !backend = Lean)); + (* Small trick: in Lean we use namespaces, meaning we don't need to prefix + the constructor name with the name of the type at definition site, + i.e., instead of generating `inductive Foo := | MkFoo ...` like in Coq + we generate `inductive Foo := | mk ... *) + let cons_name = + if !backend = Lean then "mk" else ctx_get_struct (AdtId def.def_id) ctx + in + let def_name = ctx_get_local_type def.def_id ctx in + extract_type_decl_variant ctx fmt type_decl_group def_name type_params + cg_params cons_name fields) + in + () + +(** Extract a nestable, muti-line comment *) +let extract_comment (fmt : F.formatter) (sl : string list) : unit = + (* Delimiters, space after we break a line *) + let ld, space, rd = + match !backend with + | Coq | FStar | HOL4 -> ("(** ", 4, " *)") + | Lean -> ("/- ", 3, " -/") + in + F.pp_open_vbox fmt space; + F.pp_print_string fmt ld; + (match sl with + | [] -> () + | s :: sl -> + F.pp_print_string fmt s; + List.iter + (fun s -> + F.pp_print_space fmt (); + F.pp_print_string fmt s) + sl); + F.pp_print_string fmt rd; + F.pp_close_box fmt () + +let extract_trait_clause_type (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = + let trait_name = ctx_get_trait_decl clause.trait_id ctx in + F.pp_print_string fmt trait_name; + extract_generic_args ctx fmt no_params_tys clause.generics + +(** Insert a space, if necessary *) +let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = + if !space then space := false else F.pp_print_space fmt () + +(** Extract the trait self clause. + + We add the trait self clause for provided methods (see {!TraitSelfClauseId}). + *) +let extract_trait_self_clause (insert_req_space : unit -> unit) + (ctx : extraction_ctx) (fmt : F.formatter) (trait_decl : trait_decl) + (params : string list) : unit = + insert_req_space (); + F.pp_print_string fmt "("; + let self_clause = ctx_get_trait_self_clause ctx in + F.pp_print_string fmt self_clause; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + let trait_id = ctx_get_trait_decl trait_decl.def_id ctx in + F.pp_print_string fmt trait_id; + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + params; + F.pp_print_string fmt ")" + +(** + - [trait_decl]: if [Some], it means we are extracting the generics for a provided + method and need to insert a trait self clause (see {!TraitSelfClauseId}). + *) +let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) + ?(use_forall_use_sep = true) ?(use_arrows = false) + ?(as_implicits : bool = false) ?(space : bool ref option = None) + ?(trait_decl : trait_decl option = None) (generics : generic_params) + (type_params : string list) (cg_params : string list) + (trait_clauses : string list) : unit = + let all_params = List.concat [ type_params; cg_params; trait_clauses ] in + (* HOL4 doesn't support const generics *) + assert (cg_params = [] || !backend <> HOL4); + let left_bracket (implicit : bool) = + if implicit && !backend <> FStar then F.pp_print_string fmt "{" + else F.pp_print_string fmt "(" + in + let right_bracket (implicit : bool) = + if implicit && !backend <> FStar then F.pp_print_string fmt "}" + else F.pp_print_string fmt ")" + in + let print_implicit_symbol (implicit : bool) = + if implicit && !backend = FStar then F.pp_print_string fmt "#" else () + in + let insert_req_space () = + match space with + | None -> F.pp_print_space fmt () + | Some space -> insert_req_space fmt space + in + (* Print the type/const generic parameters *) + if all_params <> [] then ( + if use_forall then ( + if use_forall_use_sep then ( + insert_req_space (); + F.pp_print_string fmt ":"); + insert_req_space (); + F.pp_print_string fmt "forall"); + (* Small helper - we may need to split the parameters *) + let print_generics (as_implicits : bool) (type_params : string list) + (const_generics : const_generic_var list) + (trait_clauses : trait_clause list) : unit = + (* Note that in HOL4 we don't print the type parameters. *) + if !backend <> HOL4 then ( + (* Print the type parameters *) + if type_params <> [] then ( + insert_req_space (); + (* ( *) + left_bracket as_implicits; + List.iter + (fun s -> + print_implicit_symbol as_implicits; + F.pp_print_string fmt s; + F.pp_print_space fmt ()) + type_params; + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ()); + (* ) *) + right_bracket as_implicits; + if use_arrows then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "->")); + (* Print the const generic parameters *) + List.iter + (fun (var : const_generic_var) -> + insert_req_space (); + (* ( *) + left_bracket as_implicits; + let n = ctx_get_const_generic_var var.index ctx in + print_implicit_symbol as_implicits; + F.pp_print_string fmt n; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_literal_type ctx fmt var.ty; + (* ) *) + right_bracket as_implicits; + if use_arrows then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "->")) + const_generics); + (* Print the trait clauses *) + List.iter + (fun (clause : trait_clause) -> + insert_req_space (); + (* ( *) + left_bracket as_implicits; + let n = ctx_get_local_trait_clause clause.clause_id ctx in + print_implicit_symbol as_implicits; + F.pp_print_string fmt n; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_trait_clause_type ctx fmt no_params_tys clause; + (* ) *) + right_bracket as_implicits; + if use_arrows then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "->")) + trait_clauses + in + (* If we extract the generics for a provided method for a trait declaration + (indicated by the trait decl given as input), we need to split the generics: + - we print the generics for the trait decl + - we print the trait self clause + - we print the generics for the trait method + *) + match trait_decl with + | None -> + print_generics as_implicits type_params generics.const_generics + generics.trait_clauses + | Some trait_decl -> + (* Split the generics between the generics specific to the trait decl + and those specific to the trait method *) + let open Collections.List in + let dtype_params, mtype_params = + split_at type_params (length trait_decl.generics.types) + in + let dcgs, mcgs = + split_at generics.const_generics + (length trait_decl.generics.const_generics) + in + let dtrait_clauses, mtrait_clauses = + split_at generics.trait_clauses + (length trait_decl.generics.trait_clauses) + in + (* Extract the trait decl generics - note that we can always deduce + those parameters from the trait self clause: for this reason + they are always implicit *) + print_generics true dtype_params dcgs dtrait_clauses; + (* Extract the trait self clause *) + let params = + concat + [ + dtype_params; + map + (fun (cg : const_generic_var) -> + ctx_get_const_generic_var cg.index ctx) + dcgs; + map + (fun c -> ctx_get_local_trait_clause c.clause_id ctx) + dtrait_clauses; + ] + in + extract_trait_self_clause insert_req_space ctx fmt trait_decl params; + (* Extract the method generics *) + print_generics as_implicits mtype_params mcgs mtrait_clauses) + +(** Extract a type declaration. + + This function is for all type declarations and all backends **at the exception** + of opaque (assumed/declared) types format4 HOL4. + + See {!extract_type_decl}. + *) +let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) + (extract_body : bool) : unit = + (* Sanity check *) + assert (extract_body || !backend <> HOL4); + let type_kind = + if extract_body then + match def.kind with + | Struct _ -> Some Struct + | Enum _ -> Some Enum + | Opaque -> None + else None + in + (* If in Coq and the declaration is opaque, it must have the shape: + [Axiom Ident : forall (T0 ... Tn : Type) (N0 : ...) ... (Nn : ...), ... -> ... -> ...]. + + The boolean [is_opaque_coq] is used to detect this case. + *) + let is_opaque = type_kind = None in + let is_opaque_coq = !backend = Coq && is_opaque in + let use_forall = is_opaque_coq && def.generics <> empty_generic_params in + (* Retrieve the definition name *) + let def_name = ctx_get_local_type def.def_id ctx in + (* Add the type and const generic params - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx_body, type_params, cg_params, trait_clauses = + ctx_add_generic_params def.generics ctx + in + (* Add a break before *) + if !backend <> HOL4 || not (decl_is_first_from_group kind) then + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + extract_comment fmt [ "[" ^ Print.name_to_string def.name ^ "]" ]; + F.pp_print_break fmt 0 0; + (* Open a box for the definition, so that whenever possible it gets printed on + * one line. Note however that in the case of Lean line breaks are important + * for parsing: we thus use a hovbox. *) + (match !backend with + | Coq | FStar | HOL4 -> F.pp_open_hvbox fmt 0 + | Lean -> F.pp_open_vbox fmt 0); + (* Open a box for "type TYPE_NAME (TYPE_PARAMS CONST_GEN_PARAMS) =" *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* > "type TYPE_NAME" *) + let qualif = ctx.fmt.type_decl_kind_to_qualif kind type_kind in + (match qualif with + | Some qualif -> F.pp_print_string fmt (qualif ^ " " ^ def_name) + | None -> F.pp_print_string fmt def_name); + (* HOL4 doesn't support const generics, and type definitions in HOL4 don't + support trait clauses *) + assert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4); + (* Print the generic parameters *) + extract_generic_params ctx_body fmt type_decl_group ~use_forall def.generics + type_params cg_params trait_clauses; + (* Print the "=" if we extract the body*) + if extract_body then ( + F.pp_print_space fmt (); + let eq = + match !backend with + | FStar -> "=" + | Coq -> ":=" + | Lean -> + if type_kind = Some Struct && kind = SingleNonRec then "where" + else ":=" + | HOL4 -> "=" + in + F.pp_print_string fmt eq) + else ( + (* Otherwise print ": Type", unless it is the HOL4 backend (in + which case we declare the type with `new_type`) *) + if use_forall then F.pp_print_string fmt "," + else ( + F.pp_print_space fmt (); + F.pp_print_string fmt ":"); + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ())); + (* Close the box for "type TYPE_NAME (TYPE_PARAMS) =" *) + F.pp_close_box fmt (); + (if extract_body then + match def.kind with + | Struct fields -> + extract_type_decl_struct_body ctx_body fmt type_decl_group kind def + type_params cg_params fields + | Enum variants -> + extract_type_decl_enum_body ctx_body fmt type_decl_group def def_name + type_params cg_params variants + | Opaque -> raise (Failure "Unreachable")); + (* Add the definition end delimiter *) + if !backend = HOL4 && decl_is_not_last_from_group kind then ( + F.pp_print_space fmt (); + F.pp_print_string fmt ";") + else if !backend = Coq && decl_is_last_from_group kind then ( + (* This is actually an end of group delimiter. For aesthetic reasons + we print it here instead of in {!end_type_decl_group}. *) + F.pp_print_cut fmt (); + F.pp_print_string fmt "."); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + if !backend <> HOL4 || decl_is_not_last_from_group kind then + F.pp_print_break fmt 0 0 + +(** Extract an opaque type declaration to HOL4. + + Remark (SH): having to treat this specific case separately is very annoying, + but I could not find a better way. + *) +let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) + (def : type_decl) : unit = + (* Retrieve the definition name *) + let def_name = ctx_get_local_type def.def_id ctx in + (* Generic parameters are unsupported *) + assert (def.generics.const_generics = []); + (* Trait clauses on type definitions are unsupported *) + assert (def.generics.trait_clauses = []); + (* Types *) + (* Count the number of parameters *) + let num_params = List.length def.generics.types in + (* Generate the declaration *) + F.pp_print_space fmt (); + F.pp_print_string fmt + ("val _ = new_type (\"" ^ def_name ^ "\", " ^ string_of_int num_params ^ ")"); + F.pp_print_space fmt () + +(** Extract an empty record type declaration to HOL4. + + Empty records are not supported in HOL4, so we extract them as type + abbreviations to the unit type. + + Remark (SH): having to treat this specific case separately is very annoying, + but I could not find a better way. + *) +let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) + (fmt : F.formatter) (def : type_decl) : unit = + (* Retrieve the definition name *) + let def_name = ctx_get_local_type def.def_id ctx in + (* Sanity check *) + assert (def.generics = empty_generic_params); + (* Generate the declaration *) + F.pp_print_space fmt (); + F.pp_print_string fmt ("Type " ^ def_name ^ " = “: unit”"); + F.pp_print_space fmt () + +(** Extract a type declaration. + + Note that all the names used for extraction should already have been + registered. + + This function should be inserted between calls to {!start_type_decl_group} + and {!end_type_decl_group}. + *) +let extract_type_decl (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) : + unit = + let extract_body = + match kind with + | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> true + | Assumed | Declared -> false + in + if extract_body then + if !backend = HOL4 && is_empty_record_type_decl def then + extract_type_decl_hol4_empty_record ctx fmt def + else extract_type_decl_gen ctx fmt type_decl_group kind def extract_body + else + match !backend with + | FStar | Coq | Lean -> + extract_type_decl_gen ctx fmt type_decl_group kind def extract_body + | HOL4 -> extract_type_decl_hol4_opaque ctx fmt def + +(** Generate a [Argument] instruction in Coq to allow omitting implicit + arguments for variants, fields, etc.. + + For instance, provided we have this definition: + {[ + Inductive result A := + | Return : A -> result A + | Fail_ : error -> result A. + ]} + + We may want to generate those instructions: + {[ + Arguments Return {_} a. + Arguments Fail_ {_}. + ]} + *) +let extract_coq_arguments_instruction (ctx : extraction_ctx) (fmt : F.formatter) + (cons_name : string) (num_implicit_params : int) : unit = + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Open a box *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_break fmt 0 0; + F.pp_print_string fmt "Arguments"; + F.pp_print_space fmt (); + F.pp_print_string fmt cons_name; + (* Print the type/const params and the trait clauses (`{T}`) *) + F.pp_print_space fmt (); + F.pp_print_string fmt "{"; + Collections.List.iter_times num_implicit_params (fun () -> + F.pp_print_space fmt (); + F.pp_print_string fmt "_"); + F.pp_print_space fmt (); + F.pp_print_string fmt "}."; + + (* Close the box *) + F.pp_close_box fmt () + +(** Auxiliary function. + + Generate [Arguments] instructions in Coq for type definitions. + *) +let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) + (kind : decl_kind) (decl : type_decl) : unit = + assert (!backend = Coq); + (* Generating the [Arguments] instructions is useful only if there are parameters *) + let num_params = + List.length decl.generics.types + + List.length decl.generics.const_generics + + List.length decl.generics.trait_clauses + in + if num_params = 0 then () + else + (* Generate the [Arguments] instruction *) + match decl.kind with + | Opaque -> () + | Struct fields -> + let adt_id = AdtId decl.def_id in + (* Generate the instruction for the record constructor *) + let cons_name = ctx_get_struct adt_id ctx in + extract_coq_arguments_instruction ctx fmt cons_name num_params; + (* Generate the instruction for the record projectors, if there are *) + let is_rec = decl_is_from_rec_group kind in + if not is_rec then + FieldId.iteri + (fun fid _ -> + let cons_name = ctx_get_field adt_id fid ctx in + extract_coq_arguments_instruction ctx fmt cons_name num_params) + fields; + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + | Enum variants -> + (* Generate the instructions *) + VariantId.iteri + (fun vid (_ : variant) -> + let cons_name = ctx_get_variant (AdtId decl.def_id) vid ctx in + extract_coq_arguments_instruction ctx fmt cons_name num_params) + variants; + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Auxiliary function. + + Generate field projectors in Coq. + + Sometimes we extract records as inductives in Coq: when this happens we + have to define the field projectors afterwards. + *) +let extract_type_decl_record_field_projectors (ctx : extraction_ctx) + (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = + assert (!backend = Coq); + match decl.kind with + | Opaque | Enum _ -> () + | Struct fields -> + (* Records are extracted as inductives only if they are recursive *) + let is_rec = decl_is_from_rec_group kind in + if is_rec then + (* Add the type params *) + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params decl.generics ctx + in + let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in + let ctx, field_var = ctx_add_var "x" (VarId.of_int 1) ctx in + let def_name = ctx_get_local_type decl.def_id ctx in + let cons_name = ctx_get_struct (AdtId decl.def_id) ctx in + let extract_field_proj (field_id : FieldId.id) (_ : field) : unit = + F.pp_print_space fmt (); + (* Outer box for the projector definition *) + F.pp_open_hvbox fmt 0; + (* Inner box for the projector definition *) + F.pp_open_hvbox fmt ctx.indent_incr; + (* Open a box for the [Definition PROJ ... :=] *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_string fmt "Definition"; + F.pp_print_space fmt (); + let field_name = ctx_get_field (AdtId decl.def_id) field_id ctx in + F.pp_print_string fmt field_name; + (* Print the generics *) + let as_implicits = true in + extract_generic_params ctx fmt TypeDeclId.Set.empty ~as_implicits + decl.generics type_params cg_params trait_clauses; + (* Print the record parameter *) + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + F.pp_print_string fmt record_var; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt def_name; + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + type_params; + F.pp_print_string fmt ")"; + (* *) + F.pp_print_space fmt (); + F.pp_print_string fmt ":="; + (* Close the box for the [Definition PROJ ... :=] *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + (* Open a box for the whole match *) + F.pp_open_hvbox fmt 0; + (* Open a box for the [match ... with] *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_string fmt "match"; + F.pp_print_space fmt (); + F.pp_print_string fmt record_var; + F.pp_print_space fmt (); + F.pp_print_string fmt "with"; + (* Close the box for the [match ... with] *) + F.pp_close_box fmt (); + + (* Open a box for the branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the match branch *) + F.pp_print_space fmt (); + F.pp_print_string fmt "|"; + F.pp_print_space fmt (); + F.pp_print_string fmt cons_name; + FieldId.iteri + (fun id _ -> + F.pp_print_space fmt (); + if field_id = id then F.pp_print_string fmt field_var + else F.pp_print_string fmt "_") + fields; + F.pp_print_space fmt (); + F.pp_print_string fmt "=>"; + F.pp_print_space fmt (); + F.pp_print_string fmt field_var; + (* Close the box for the branch *) + F.pp_close_box fmt (); + (* Print the [end] *) + F.pp_print_space fmt (); + F.pp_print_string fmt "end"; + (* Close the box for the whole match *) + F.pp_close_box fmt (); + (* Close the inner box projector *) + F.pp_close_box fmt (); + (* If Coq: end the definition with a "." *) + if !backend = Coq then ( + F.pp_print_cut fmt (); + F.pp_print_string fmt "."); + (* Close the outer box projector *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + in + + let extract_proj_notation (field_id : FieldId.id) (_ : field) : unit = + F.pp_print_space fmt (); + (* Outer box for the projector definition *) + F.pp_open_hvbox fmt 0; + (* Inner box for the projector definition *) + F.pp_open_hovbox fmt ctx.indent_incr; + let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in + F.pp_print_string fmt "Notation"; + F.pp_print_space fmt (); + let field_name = ctx_get_field (AdtId decl.def_id) field_id ctx in + F.pp_print_string fmt ("\"" ^ record_var ^ " .(" ^ field_name ^ ")\""); + F.pp_print_space fmt (); + F.pp_print_string fmt ":="; + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + F.pp_print_string fmt field_name; + F.pp_print_space fmt (); + F.pp_print_string fmt record_var; + F.pp_print_string fmt ")"; + F.pp_print_space fmt (); + F.pp_print_string fmt "(at level 9)"; + (* Close the inner box projector *) + F.pp_close_box fmt (); + (* If Coq: end the definition with a "." *) + if !backend = Coq then ( + F.pp_print_cut fmt (); + F.pp_print_string fmt "."); + (* Close the outer box projector *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + in + + let extract_field_proj_and_notation (field_id : FieldId.id) + (field : field) : unit = + extract_field_proj field_id field; + extract_proj_notation field_id field + in + + FieldId.iteri extract_field_proj_and_notation fields + +(** Extract extra information for a type (e.g., [Arguments] instructions in Coq). + + Note that all the names used for extraction should already have been + registered. + *) +let extract_type_decl_extra_info (ctx : extraction_ctx) (fmt : F.formatter) + (kind : decl_kind) (decl : type_decl) : unit = + match !backend with + | FStar | Lean | HOL4 -> () + | Coq -> + extract_type_decl_coq_arguments ctx fmt kind decl; + extract_type_decl_record_field_projectors ctx fmt kind decl + +(** Extract the state type declaration. *) +let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) + (kind : decl_kind) : unit = + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment *) + extract_comment fmt [ "The state type used in the state-error monad" ]; + F.pp_print_break fmt 0 0; + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt 0; + (* Retrieve the name *) + let state_name = ctx_get_assumed_type State ctx in + (* The syntax for Lean and Coq is almost identical. *) + let print_axiom () = + let axiom = + match !backend with + | Coq -> "Axiom" + | Lean -> "axiom" + | FStar | HOL4 -> raise (Failure "Unexpected") + in + F.pp_print_string fmt axiom; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type"; + if !backend = Coq then F.pp_print_string fmt "." + in + (* The kind should be [Assumed] or [Declared] *) + (match kind with + | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> + raise (Failure "Unexpected") + | Assumed -> ( + match !backend with + | FStar -> + F.pp_print_string fmt "assume"; + F.pp_print_space fmt (); + F.pp_print_string fmt "type"; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0" + | HOL4 -> + F.pp_print_string fmt ("val _ = new_type (\"" ^ state_name ^ "\", 0)") + | Coq | Lean -> print_axiom ()) + | Declared -> ( + match !backend with + | FStar -> + F.pp_print_string fmt "val"; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0" + | HOL4 -> + F.pp_print_string fmt ("val _ = new_type (\"" ^ state_name ^ "\", 0)") + | Coq | Lean -> print_axiom ())); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index b72fa078..e17ea16f 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -57,12 +57,26 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let stateful = ref false in let can_diverge = ref false in let is_rec = ref false in + let group_has_builtin_info = ref false in + + (* We have some specialized knowledge of some library functions; we don't + have any more custom treatment than this, and these functions can be modeled + suitably in Primitives.fst, rather than special-casing for them all the + way. *) + let get_builtin_info (f : fun_decl) : ExtractBuiltin.effect_info option = + let open ExtractBuiltin in + let name = name_to_simple_name f.name in + SimpleNameMap.find_opt name builtin_fun_effects_map + in + (* JP: Why not use a reduce visitor here with a tuple of the values to be + computed? *) let visit_fun (f : fun_decl) : unit = let obj = object (self) inherit [_] iter_statement as super method may_fail b = can_fail := !can_fail || b + method maybe_stateful b = stateful := !stateful || b method! visit_Assert env a = self#may_fail true; @@ -70,14 +84,14 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) method! visit_rvalue _env rv = match rv with - | Use _ | Ref _ | Global _ | Discriminant _ | Aggregate _ -> () + | Use _ | RvRef _ | Global _ | Discriminant _ | Aggregate _ -> () | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail | BinaryOp (bop, _, _) -> can_fail := EU.binop_can_fail bop || !can_fail method! visit_Call env call = - (match call.func with - | Regular id -> + (match call.func.func with + | FunId (Regular id) -> if FunDeclId.Set.mem id fun_ids then ( can_diverge := true; is_rec := true) @@ -86,9 +100,14 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) self#may_fail info.can_fail; stateful := !stateful || info.stateful; can_diverge := !can_diverge || info.can_diverge - | Assumed id -> + | FunId (Assumed id) -> (* None of the assumed functions can diverge nor are considered stateful *) - can_fail := !can_fail || Assumed.assumed_can_fail id); + can_fail := !can_fail || Assumed.assumed_fun_can_fail id + | TraitMethod _ -> + (* We consider trait functions can fail, but can not diverge and are not stateful. + TODO: this may cause issues if we use use a fuel parameter. + *) + can_fail := true); super#visit_Call env call method! visit_Panic env = @@ -102,11 +121,21 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) in (* Sanity check: global bodies don't contain stateful calls *) assert ((not f.is_global_decl_body) || not !stateful); + let builtin_info = get_builtin_info f in + let has_builtin_info = builtin_info <> None in + group_has_builtin_info := !group_has_builtin_info || has_builtin_info; match f.body with | None -> - (* Opaque function: we consider they fail by default *) - obj#may_fail true; - stateful := (not f.is_global_decl_body) && use_state + let info_can_fail, info_stateful = + match builtin_info with + | None -> (true, use_state) + | Some { can_fail; stateful } -> (can_fail, stateful) + in + obj#may_fail info_can_fail; + obj#maybe_stateful + (if f.is_global_decl_body then false + else if not use_state then false + else info_stateful) | Some body -> obj#visit_statement () body.body in List.iter visit_fun d; @@ -114,12 +143,17 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) * groups containing globals contain exactly one declaration *) let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in assert ((not is_global_decl_body) || List.length d = 1); + assert ((not !group_has_builtin_info) || List.length d = 1); (* We ignore on purpose functions that cannot fail and consider they *can* * fail: the result of the analysis is not used yet to adjust the translation * so that the functions which syntactically can't fail don't use an error monad. - * However, we do keep the result of the analysis for global bodies. + * However, we do keep the result of the analysis for global bodies and for + * builtin functions which are marked as non-fallible. * *) - can_fail := (not is_global_decl_body) || !can_fail; + can_fail := + if is_global_decl_body then !can_fail + else if !group_has_builtin_info then !can_fail + else true; { can_fail = !can_fail; stateful = !stateful; @@ -141,7 +175,8 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let rec analyze_decl_groups (decls : declaration_group list) : unit = match decls with | [] -> () - | Type _ :: decls' -> analyze_decl_groups decls' + | (Type _ | TraitDecl _ | TraitImpl _) :: decls' -> + analyze_decl_groups decls' | Fun decl :: decls' -> analyze_fun_decl_group decl; analyze_decl_groups decls' diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 154c5a21..24ff4808 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -12,55 +12,165 @@ module SA = SymbolicAst (** The local logger *) let log = L.interpreter_log -let compute_type_fun_global_contexts (m : A.crate) : - C.type_context * C.fun_context * C.global_context = - let type_decls_list, _, _ = split_declarations m.declarations in +let compute_contexts (m : A.crate) : C.decls_ctx = + let type_decls_list, _, _, _, _ = split_declarations m.declarations in let type_decls = m.types in let fun_decls = m.functions in let global_decls = m.globals in - let type_decls_groups, _funs_defs_groups, _globals_defs_groups = + let trait_decls = m.trait_decls in + let trait_impls = m.trait_impls in + let type_decls_groups, _, _, _, _ = split_declarations_to_group_maps m.declarations in let type_infos = TypesAnalysis.analyze_type_declarations type_decls type_decls_list in - let type_context = { C.type_decls_groups; type_decls; type_infos } in - let fun_context = { C.fun_decls } in - let global_context = { C.global_decls } in - (type_context, fun_context, global_context) - -let initialize_eval_context (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) - (const_generic_vars : T.const_generic_var list) : C.eval_ctx = - C.reset_global_counters (); - { - C.type_context; - C.fun_context; - C.global_context; - C.region_groups; - C.type_vars; - C.const_generic_vars; - C.env = [ C.Frame ]; - C.ended_regions = T.RegionId.Set.empty; - } + let type_ctx = { C.type_decls_groups; type_decls; type_infos } in + let fun_infos = + FunsAnalysis.analyze_module m fun_decls global_decls !Config.use_state + in + let fun_ctx = { C.fun_decls; fun_infos } in + let global_ctx = { C.global_decls } in + let trait_decls_ctx = { C.trait_decls } in + let trait_impls_ctx = { C.trait_impls } in + { C.type_ctx; fun_ctx; global_ctx; trait_decls_ctx; trait_impls_ctx } + +(** Small helper. + + Normalize an instantiated function signature provided we used this signature + to compute a normalization map (for the associated types) and that we added + it in the context. + *) +let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : + A.inst_fun_sig = + let { A.regions_hierarchy = _; trait_type_constraints = _; inputs; output } = + sg + in + let norm = AssociatedTypes.ctx_normalize_rty ctx in + let inputs = List.map norm inputs in + let output = norm output in + { sg with A.inputs; output } + +(** Instantiate a function signature for a symbolic execution. + + We return a new context because we compute and add the type normalization + map in the same step. + + **WARNING**: this doesn't normalize the types. This step has to be done + separately. Remark: we need to normalize essentially because of the where + clauses (we are not considering a function call, so we don't need to + normalize because a trait clause was instantiated with a specific trait ref). + *) +let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) + (kind : A.fun_kind) : C.eval_ctx * A.inst_fun_sig = + let tr_self = + match kind with + | RegularKind | TraitMethodImpl _ -> T.UnknownTrait __FUNCTION__ + | TraitMethodDecl _ | TraitMethodProvided _ -> T.Self + in + let generics = + let { T.regions; types; const_generics; trait_clauses } = sg.generics in + let regions = List.map (fun _ -> T.Erased) regions in + let types = List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) types in + let const_generics = + List.map + (fun (v : T.const_generic_var) -> T.ConstGenericVar v.T.index) + const_generics + in + (* Annoying that we have to generate this substitution here *) + let r_subst _ = raise (Failure "Unexpected region") in + let ty_subst = Subst.make_type_subst_from_vars sg.generics.types types in + let cg_subst = + Subst.make_const_generic_subst_from_vars sg.generics.const_generics + const_generics + in + (* TODO: some clauses may use the types of other clauses, so we may have to + reorder them. + + Example: + If in Rust we write: + {[ + pub fn use_get<'a, T: Get>(x: &'a mut T) -> u32 + where + T::Item: ToU32, + { + x.get().to_u32() + } + ]} + + In LLBC we get: + {[ + fn demo::use_get<'a, T>(@1: &'a mut (T)) -> u32 + where + [@TraitClause0]: demo::Get<T>, + [@TraitClause1]: demo::ToU32<@TraitClause0::Item>, // HERE + { + ... // Omitted + } + ]} + *) + (* We will need to update the trait refs map while we perform the instantiations *) + let mk_tr_subst + (tr_map : T.erased_region T.trait_instance_id T.TraitClauseId.Map.t) + clause_id : T.erased_region T.trait_instance_id = + match T.TraitClauseId.Map.find_opt clause_id tr_map with + | Some tr -> tr + | None -> raise (Failure "Local trait clause not found") + in + let mk_subst tr_map = + let tr_subst = mk_tr_subst tr_map in + { Subst.r_subst; ty_subst; cg_subst; tr_subst; tr_self } + in + let _, trait_refs = + List.fold_left_map + (fun tr_map (c : T.trait_clause) -> + let subst = mk_subst tr_map in + let { T.trait_id = trait_decl_id; generics; _ } = c in + let generics = Subst.generic_args_substitute subst generics in + let trait_decl_ref = { T.trait_decl_id; decl_generics = generics } in + (* Note that because we directly refer to the clause, we give it + empty generics *) + let trait_id = T.Clause c.clause_id in + let trait_ref = + { + T.trait_id; + generics = TypesUtils.mk_empty_generic_args; + trait_decl_ref; + } + in + (* Update the traits map *) + let tr_map = T.TraitClauseId.Map.add c.T.clause_id trait_id tr_map in + (tr_map, trait_ref)) + T.TraitClauseId.Map.empty trait_clauses + in + { T.regions; types; const_generics; trait_refs } + in + let inst_sg = instantiate_fun_sig ctx generics tr_self sg in + (* Compute the normalization maps *) + let ctx = + AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx + inst_sg.trait_type_constraints + in + (* Normalize the signature *) + let inst_sg = normalize_inst_fun_sig ctx inst_sg in + (* Return *) + (ctx, inst_sg) (** Initialize an evaluation context to execute a function. - Introduces local variables initialized in the following manner: - - input arguments are initialized as symbolic values - - the remaining locals are initialized as [⊥] - Abstractions are introduced for the regions present in the function - signature. - - We return: - - the initialized evaluation context - - the list of symbolic values introduced for the input values - - the instantiated function signature + Introduces local variables initialized in the following manner: + - input arguments are initialized as symbolic values + - the remaining locals are initialized as [⊥] + Abstractions are introduced for the regions present in the function + signature. + + We return: + - the initialized evaluation context + - the list of symbolic values introduced for the input values + - the instantiated function signature *) -let initialize_symbolic_context_for_fun (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (fdef : A.fun_decl) : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = +let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) + : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = (* The abstractions are not initialized the same way as for function * calls: they contain *loan* projectors, because they "provide" us * with the input values (which behave as if they had been returned @@ -78,19 +188,15 @@ let initialize_symbolic_context_for_fun (type_context : C.type_context) List.map (fun (g : T.region_var_group) -> g.id) sg.regions_hierarchy in let ctx = - initialize_eval_context type_context fun_context global_context - region_groups sg.type_params sg.const_generic_params + initialize_eval_context ctx region_groups sg.generics.types + sg.generics.const_generics in - (* Instantiate the signature *) - let type_params = - List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) sg.type_params + (* Instantiate the signature. This updates the context because we compute + at the same time the normalization map for the associated types. + *) + let ctx, inst_sg = + symbolic_instantiate_fun_sig ctx fdef.signature fdef.kind in - let cg_params = - List.map - (fun (v : T.const_generic_var) -> T.ConstGenericVar v.T.index) - sg.const_generic_params - in - let inst_sg = instantiate_fun_sig type_params cg_params sg in (* Create fresh symbolic values for the inputs *) let input_svs = List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs @@ -165,15 +271,9 @@ let evaluate_function_symbolic_synthesize_backward_from_return * an instantiation of the signature, so that we use fresh * region ids for the return abstractions. *) let sg = fdef.signature in - let type_params = - List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) sg.type_params - in - let cg_params = - List.map - (fun (v : T.const_generic_var) -> T.ConstGenericVar v.T.index) - sg.const_generic_params + let _, ret_inst_sg = + symbolic_instantiate_fun_sig ctx fdef.signature fdef.kind in - let ret_inst_sg = instantiate_fun_sig type_params cg_params sg in let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) let pop_return_value = is_regular_return in @@ -347,19 +447,14 @@ let evaluate_function_symbolic_synthesize_backward_from_return for the synthesis) - the symbolic AST generated by the symbolic execution *) -let evaluate_function_symbolic (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) - (global_context : C.global_context) (fdef : A.fun_decl) : - V.symbolic_value list * SA.expression option = +let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) + (fdef : A.fun_decl) : V.symbolic_value list * SA.expression option = (* Debug *) let name_to_string () = Print.fun_name_to_string fdef.A.name in log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); (* Create the evaluation context *) - let ctx, input_svs, inst_sg = - initialize_symbolic_context_for_fun type_context fun_context global_context - fdef - in + let ctx, input_svs, inst_sg = initialize_symbolic_context_for_fun ctx fdef in (* Create the continuation to finish the evaluation *) let config = C.mk_config C.SymbolicMode in @@ -488,7 +583,8 @@ module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty environment. *) - let test_unit_function (crate : A.crate) (fid : A.FunDeclId.id) : unit = + let test_unit_function (crate : A.crate) (decls_ctx : C.decls_ctx) + (fid : A.FunDeclId.id) : unit = (* Retrieve the function declaration *) let fdef = A.FunDeclId.Map.find fid crate.functions in let body = Option.get fdef.body in @@ -498,17 +594,11 @@ module Test = struct (lazy ("test_unit_function: " ^ Print.fun_name_to_string fdef.A.name)); (* Sanity check - *) - assert (List.length fdef.A.signature.region_params = 0); - assert (List.length fdef.A.signature.type_params = 0); + assert (fdef.A.signature.generics = TypesUtils.mk_empty_generic_params); assert (body.A.arg_count = 0); (* Create the evaluation context *) - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let ctx = - initialize_eval_context type_context fun_context global_context [] [] [] - in + let ctx = initialize_eval_context decls_ctx [] [] [] in (* Insert the (uninitialized) local variables *) let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in @@ -536,9 +626,7 @@ module Test = struct (no parameters, no arguments) - TODO: move *) let fun_decl_is_transparent_unit (def : A.fun_decl) : bool = Option.is_some def.body - && def.A.signature.region_params = [] - && def.A.signature.type_params = [] - && def.A.signature.const_generic_params = [] + && def.A.signature.generics = TypesUtils.mk_empty_generic_params && def.A.signature.inputs = [] (** Test all the unit functions in a list of function definitions *) @@ -548,24 +636,9 @@ module Test = struct (fun _ -> fun_decl_is_transparent_unit) crate.functions in + let decls_ctx = compute_contexts crate in let test_unit_fun _ (def : A.fun_decl) : unit = - test_unit_function crate def.A.def_id + test_unit_function crate decls_ctx def.A.def_id in A.FunDeclId.Map.iter test_unit_fun unit_funs - - (** Execute the symbolic interpreter on a function. *) - let test_function_symbolic (synthesize : bool) (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (fdef : A.fun_decl) : unit = - (* Debug *) - log#ldebug - (lazy ("test_function_symbolic: " ^ Print.fun_name_to_string fdef.A.name)); - - (* Evaluate *) - let _ = - evaluate_function_symbolic synthesize type_context fun_context - global_context fdef - in - - () end diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 4d67a4e4..e97795a1 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -452,7 +452,8 @@ let give_back_symbolic_value (_config : C.config) | V.SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack -> () - | FunCallRet | SynthInput | Global | LoopOutput | LoopJoin | Aggregate -> + | FunCallRet | SynthInput | Global | LoopOutput | LoopJoin | Aggregate + | ConstGeneric | TraitConst -> raise (Failure "Unreachable")); (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index bf083aa4..e7da045c 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -100,15 +100,18 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) (compare_regions : T.RegionId.id T.region -> T.RegionId.id T.region -> bool) (ty1 : T.rty) (ty2 : T.rty) : bool = let compare = compare_rtys default combine compare_regions in + (* Normalize the associated types *) match (ty1, ty2) with | T.Literal lit1, T.Literal lit2 -> assert (lit1 = lit2); default - | T.Adt (id1, regions1, tys1, cgs1), T.Adt (id2, regions2, tys2, cgs2) -> + | T.Adt (id1, generics1), T.Adt (id2, generics2) -> assert (id1 = id2); (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) - assert (cgs1 = cgs2); + assert (generics1.const_generics = generics2.const_generics); + + (* We also ignore the trait refs *) (* The check for the ADTs is very crude: we simply compare the arguments * two by two. @@ -123,14 +126,14 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) * this check would still be a reasonable conservative approximation. *) (* Check the region parameters *) - let regions = List.combine regions1 regions2 in + let regions = List.combine generics1.regions generics2.regions in let params_b = List.fold_left (fun b (r1, r2) -> combine b (compare_regions r1 r2)) default regions in (* Check the type parameters *) - let tys = List.combine tys1 tys2 in + let tys = List.combine generics1.types generics2.types in let tys_b = List.fold_left (fun b (ty1, ty2) -> combine b (compare ty1 ty2)) @@ -150,6 +153,11 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) | T.TypeVar id1, T.TypeVar id2 -> assert (id1 = id2); default + | T.TraitType _, T.TraitType _ -> + (* The types should have been normalized. If after normalization we + get trait types, we can consider them as variables *) + assert (ty1 = ty2); + default | _ -> log#lerror (lazy diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 81e73e3e..b267bb51 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -9,6 +9,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open TypesUtils module Inv = Invariants @@ -204,7 +205,7 @@ let apply_symbolic_expansion_non_borrow (config : C.config) apply_symbolic_expansion_to_avalues config allow_reborrows original_sv expansion ctx -(** Compute the expansion of a non-assumed (i.e.: not [Option], [Box], etc.) +(** Compute the expansion of a non-assumed (i.e.: not [Box], etc.) adt value. The function might return a list of values if the symbolic value to expand @@ -214,18 +215,15 @@ let apply_symbolic_expansion_non_borrow (config : C.config) doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (def_id : T.TypeDeclId.id) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) (ctx : C.eval_ctx) : V.symbolic_expansion list - = + (kind : V.sv_kind) (def_id : T.TypeDeclId.id) (generics : T.rgeneric_args) + (ctx : C.eval_ctx) : V.symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) let def = C.ctx_lookup_type_decl ctx def_id in - assert (List.length regions = List.length def.T.region_params); + assert (List.length generics.regions = List.length def.T.generics.regions); (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = - Subst.type_decl_get_instantiated_variants_fields_rtypes def regions types - cgs + Assoc.type_decl_get_inst_norm_variants_fields_rtypes ctx def generics in (* Check if there is strictly more than one variant *) if List.length variants_fields_types > 1 && not expand_enumerations then @@ -243,17 +241,6 @@ let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) (* Initialize all the expanded values of all the variants *) List.map initialize variants_fields_types -(** Compute the expansion of an Option value. - *) -let compute_expanded_symbolic_option_value (expand_enumerations : bool) - (kind : V.sv_kind) (ty : T.rty) : V.symbolic_expansion list = - assert expand_enumerations; - let some_se = - V.SeAdt (Some T.option_some_id, [ mk_fresh_symbolic_value kind ty ]) - in - let none_se = V.SeAdt (Some T.option_none_id, []) in - [ none_se; some_se ] - let compute_expanded_symbolic_tuple_value (kind : V.sv_kind) (field_types : T.rty list) : V.symbolic_expansion = (* Generate the field values *) @@ -280,17 +267,14 @@ let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (adt_id : T.type_id) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) (ctx : C.eval_ctx) : V.symbolic_expansion list - = - match (adt_id, regions, types) with + (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.rgeneric_args) + (ctx : C.eval_ctx) : V.symbolic_expansion list = + match (adt_id, generics.regions, generics.types) with | T.AdtId def_id, _, _ -> compute_expanded_symbolic_non_assumed_adt_value expand_enumerations kind - def_id regions types cgs ctx - | T.Tuple, [], _ -> [ compute_expanded_symbolic_tuple_value kind types ] - | T.Assumed T.Option, [], [ ty ] -> - compute_expanded_symbolic_option_value expand_enumerations kind ty + def_id generics ctx + | T.Tuple, [], _ -> + [ compute_expanded_symbolic_tuple_value kind generics.types ] | T.Assumed T.Box, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value kind boxed_ty ] | _ -> @@ -543,12 +527,12 @@ let expand_symbolic_value_no_branching (config : C.config) fun cf ctx -> match rty with (* ADTs *) - | T.Adt (adt_id, regions, types, cgs) -> + | T.Adt (adt_id, generics) -> (* Compute the expanded value *) let allow_branching = false in let seel = compute_expanded_symbolic_adt_value allow_branching sv.sv_kind adt_id - regions types cgs ctx + generics ctx in (* There should be exacly one branch *) let see = Collections.List.to_cons_nil seel in @@ -600,12 +584,12 @@ let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) (* Execute *) match rty with (* ADTs *) - | T.Adt (adt_id, regions, types, cgs) -> + | T.Adt (adt_id, generics) -> let allow_branching = true in (* Compute the expanded value *) let seel = compute_expanded_symbolic_adt_value allow_branching sv.sv_kind adt_id - regions types cgs ctx + generics ctx in (* Apply *) let seel = List.map (fun see -> (Some see, cf_branches)) seel in @@ -679,7 +663,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = ^ symbolic_value_to_string ctx sv)); let cc : cm_fun = match sv.V.sv_ty with - | T.Adt (AdtId def_id, _, _, _) -> + | T.Adt (AdtId def_id, _) -> (* {!expand_symbolic_value_no_branching} checks if there are branchings, * but we prefer to also check it here - this leads to cleaner messages * and debugging *) @@ -704,16 +688,17 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = [config]): " ^ Print.name_to_string def.name)) else expand_symbolic_value_no_branching config sv None - | T.Adt ((Tuple | Assumed Box), _, _, _) | T.Ref (_, _, _) -> + | T.Adt ((Tuple | Assumed Box), _) | T.Ref (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config sv None - | T.Adt (Assumed (Vec | Option | Array | Slice | Str | Range), _, _, _) - -> + | T.Adt (Assumed (Array | Slice | Str), _) -> (* We can't expand those *) raise (Failure "Attempted to greedily expand an ADT which can't be expanded ") - | T.TypeVar _ | T.Literal _ | Never -> raise (Failure "Unreachable") + | T.TypeVar _ | T.Literal _ | Never | T.TraitType _ | T.Arrow _ + | T.RawPtr _ -> + raise (Failure "Unreachable") in (* Compose and continue *) comp cc expand cf ctx diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 8b2070c6..245f3b77 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -7,6 +7,7 @@ module E = Expressions open Utils module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open TypesUtils open ValuesUtils @@ -141,11 +142,19 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) | V.Adt av -> (* Sanity check *) (match v.V.ty with - | T.Adt (T.Assumed (T.Box | Vec), _, _, _) -> + | T.Adt (T.Assumed T.Box, _) -> raise (Failure "Can't copy an assumed value other than Option") - | T.Adt (T.AdtId _, _, _, _) -> assert allow_adt_copy - | T.Adt ((T.Assumed Option | T.Tuple), _, _, _) -> () (* Ok *) - | T.Adt (T.Assumed (Slice | T.Array), [], [ ty ], []) -> + | T.Adt (T.AdtId _, _) as ty -> + assert (allow_adt_copy || ty_is_primitively_copyable ty) + | T.Adt (T.Tuple, _) -> () (* Ok *) + | T.Adt + ( T.Assumed (Slice | T.Array), + { + regions = []; + types = [ ty ]; + const_generics = []; + trait_refs = []; + } ) -> assert (ty_is_primitively_copyable ty) | _ -> raise (Failure "Unreachable")); let ctx, fields = @@ -230,17 +239,16 @@ let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : let prepare : cm_fun = fun cf ctx -> match op with - | Expressions.Constant (ty, cv) -> + | E.Constant _ -> (* No need to reorganize the context *) - literal_to_typed_value (TypesUtils.ty_as_literal ty) cv |> ignore; cf ctx - | Expressions.Copy p -> + | E.Copy p -> (* Access the value *) let access = Read in (* Expand the symbolic values, if necessary *) let expand_prim_copy = true in access_rplace_reorganize config expand_prim_copy access p cf ctx - | Expressions.Move p -> + | E.Move p -> (* Access the value *) let access = Move in let expand_prim_copy = false in @@ -260,9 +268,71 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* Evaluate *) match op with - | Expressions.Constant (ty, cv) -> - cf (literal_to_typed_value (TypesUtils.ty_as_literal ty) cv) ctx - | Expressions.Copy p -> + | E.Constant cv -> ( + match cv.value with + | E.CLiteral lit -> + cf (literal_to_typed_value (TypesUtils.ty_as_literal cv.ty) lit) ctx + | E.CTraitConst (trait_ref, generics, const_name) -> ( + assert (generics = TypesUtils.mk_empty_generic_args); + match trait_ref.trait_id with + | T.TraitImpl _ -> + (* This shouldn't happen: if we refer to a concrete implementation, we + should directly refer to the top-level constant *) + raise (Failure "Unreachable") + | _ -> ( + (* We refer to a constant defined in a local clause: simply + introduce a fresh symbolic value *) + let ctx0 = ctx in + (* Lookup the trait declaration to retrieve the type of the symbolic value *) + let trait_decl = + C.ctx_lookup_trait_decl ctx + trait_ref.trait_decl_ref.trait_decl_id + in + let _, (ty, _) = + List.find (fun (name, _) -> name = const_name) trait_decl.consts + in + (* Introduce a fresh symbolic value *) + let v = mk_fresh_symbolic_typed_value_from_ety V.TraitConst ty in + (* Continue the evaluation *) + let e = cf v ctx in + (* We have to wrap the generated expression *) + match e with + | None -> None + | Some e -> + Some + (SymbolicAst.IntroSymbolic + ( ctx0, + None, + value_as_symbolic v.value, + SymbolicAst.TraitConstValue + (trait_ref, generics, const_name), + e )))) + | E.CVar vid -> ( + let ctx0 = ctx in + (* Lookup the const generic value *) + let cv = C.ctx_lookup_const_generic_value ctx vid in + (* Copy the value *) + let allow_adt_copy = false in + let ctx, v = copy_value allow_adt_copy config ctx cv in + (* Continue *) + let e = cf v ctx in + (* We have to wrap the generated expression *) + match e with + | None -> None + | Some e -> + (* If we are synthesizing a symbolic AST, it means that we are in symbolic + mode: the value of the const generic is necessarily symbolic. *) + assert (is_symbolic cv.V.value); + (* *) + Some + (SymbolicAst.IntroSymbolic + ( ctx0, + None, + value_as_symbolic v.value, + SymbolicAst.ConstGenericValue vid, + e ))) + | E.CFnPtr _ -> raise (Failure "TODO")) + | E.Copy p -> (* Access the value *) let access = Read in let cc = read_place access p in @@ -283,7 +353,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) in (* Compose and apply *) comp cc copy cf ctx - | Expressions.Move p -> + | E.Move p -> (* Access the value *) let access = Move in let cc = read_place access p in @@ -358,7 +428,7 @@ let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) match mk_scalar sv.int_ty i with | Error _ -> cf (Error EPanic) | Ok sv -> cf (Ok { v with V.value = V.Literal (PV.Scalar sv) })) - | E.Cast (src_ty, tgt_ty), V.Literal (PV.Scalar sv) -> ( + | E.Cast (E.CastInteger (src_ty, tgt_ty)), V.Literal (PV.Scalar sv) -> ( assert (src_ty = sv.int_ty); let i = sv.PV.value in match mk_scalar tgt_ty i with @@ -384,7 +454,7 @@ let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) match (unop, v.V.ty) with | E.Not, (T.Literal Bool as lty) -> lty | E.Neg, (T.Literal (Integer _) as lty) -> lty - | E.Cast (_, tgt_ty), _ -> T.Literal (Integer tgt_ty) + | E.Cast (E.CastInteger (_, tgt_ty)), _ -> T.Literal (Integer tgt_ty) | _ -> raise (Failure "Invalid input for unop") in let res_sv = @@ -653,73 +723,46 @@ let eval_rvalue_aggregate (config : C.config) fun ctx -> (* Match on the aggregate kind *) match aggregate_kind with - | E.AggregatedTuple -> - let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.Adt { variant_id = None; field_values = values } in - let ty = T.Adt (T.Tuple, [], tys, []) in - let aggregated : V.typed_value = { V.value = v; ty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedOption (variant_id, ty) -> - (* Sanity check *) - if variant_id = T.option_none_id then assert (values = []) - else if variant_id = T.option_some_id then - assert (List.length values = 1) - else raise (Failure "Unreachable"); - (* Construt the value *) - let aty = T.Adt (T.Assumed T.Option, [], [ ty ], []) in - let av : V.adt_value = - { V.variant_id = Some variant_id; V.field_values = values } - in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedAdt (def_id, opt_variant_id, regions, types, cgs) -> - (* Sanity checks *) - let type_decl = C.ctx_lookup_type_decl ctx def_id in - assert (List.length type_decl.region_params = List.length regions); - let expected_field_types = - Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id - types cgs - in - assert ( - expected_field_types - = List.map (fun (v : V.typed_value) -> v.V.ty) values); - (* Construct the value *) - let av : V.adt_value = - { V.variant_id = opt_variant_id; V.field_values = values } - in - let aty = T.Adt (T.AdtId def_id, regions, types, cgs) in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedRange ety -> - (* There should be two fields exactly *) - let v0, v1 = - match values with - | [ v0; v1 ] -> (v0, v1) - | _ -> raise (Failure "Unreachable") - in - (* Ranges are parametric over the type of indices. For now we only - support scalars, which can be of any type *) - assert (literal_type_is_integer (ty_as_literal ety)); - assert (v0.ty = ety); - assert (v1.ty = ety); - (* Construct the value *) - let av : V.adt_value = - { V.variant_id = None; V.field_values = values } - in - let aty = T.Adt (T.Assumed T.Range, [], [ ety ], []) in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx + | E.AggregatedAdt (type_id, opt_variant_id, generics) -> ( + match type_id with + | Tuple -> + let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in + let v = V.Adt { variant_id = None; field_values = values } in + let generics = TypesUtils.mk_generic_args [] tys [] [] in + let ty = T.Adt (T.Tuple, generics) in + let aggregated : V.typed_value = { V.value = v; ty } in + (* Call the continuation *) + cf aggregated ctx + | AdtId def_id -> + (* Sanity checks *) + let type_decl = C.ctx_lookup_type_decl ctx def_id in + assert ( + List.length type_decl.generics.regions + = List.length generics.regions); + let expected_field_types = + Assoc.ctx_adt_get_inst_norm_field_etypes ctx def_id opt_variant_id + generics + in + assert ( + expected_field_types + = List.map (fun (v : V.typed_value) -> v.V.ty) values); + (* Construct the value *) + let av : V.adt_value = + { V.variant_id = opt_variant_id; V.field_values = values } + in + let aty = T.Adt (T.AdtId def_id, generics) in + let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in + (* Call the continuation *) + cf aggregated ctx + | Assumed _ -> raise (Failure "Unreachable")) | E.AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) assert (List.for_all (fun (v : V.typed_value) -> v.V.ty = ety) values); (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in assert (len = Z.of_int (List.length values)); - let ty = T.Adt (T.Assumed T.Array, [], [ ety ], [ cg ]) in + let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in + let ty = T.Adt (T.Assumed T.Array, generics) in (* In order to generate a better AST, we introduce a symbolic value equal to the array. The reason is that otherwise, the array we introduce here might be duplicated in the generated @@ -752,7 +795,7 @@ let eval_rvalue_not_global (config : C.config) (rvalue : E.rvalue) (* Delegate to the proper auxiliary function *) match rvalue with | E.Use op -> comp_wrap (eval_operand config op) ctx - | E.Ref (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx + | E.RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx | E.UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx | E.BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx | E.Aggregate (aggregate_kind, ops) -> diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index bf88e055..6d3ecb18 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -554,9 +554,15 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) C.type_context; fun_context; global_context; + trait_decls_context; + trait_impls_context; region_groups; type_vars; const_generic_vars; + const_generic_vars_map; + norm_trait_etypes; + norm_trait_rtypes; + norm_trait_stypes; env = _; ended_regions = ended_regions0; } = @@ -566,9 +572,15 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) C.type_context = _; fun_context = _; global_context = _; + trait_decls_context = _; + trait_impls_context = _; region_groups = _; type_vars = _; const_generic_vars = _; + const_generic_vars_map = _; + norm_trait_etypes = _; + norm_trait_rtypes = _; + norm_trait_stypes = _; env = _; ended_regions = ended_regions1; } = @@ -580,9 +592,15 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) C.type_context; fun_context; global_context; + trait_decls_context; + trait_impls_context; region_groups; type_vars; const_generic_vars; + const_generic_vars_map; + norm_trait_etypes; + norm_trait_rtypes; + norm_trait_stypes; env; ended_regions; } diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 9248e513..8cab546e 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -149,20 +149,25 @@ let rec match_types (match_distinct_types : 'r T.ty -> 'r T.ty -> 'r T.ty) (match_regions : 'r -> 'r -> 'r) (ty0 : 'r T.ty) (ty1 : 'r T.ty) : 'r T.ty = let match_rec = match_types match_distinct_types match_regions in match (ty0, ty1) with - | Adt (id0, regions0, tys0, cgs0), Adt (id1, regions1, tys1, cgs1) -> + | Adt (id0, generics0), Adt (id1, generics1) -> assert (id0 = id1); - assert (cgs0 = cgs1); + assert (generics0.const_generics = generics1.const_generics); + assert (generics0.trait_refs = generics1.trait_refs); let id = id0 in - let cgs = cgs1 in + let const_generics = generics1.const_generics in + let trait_refs = generics1.trait_refs in let regions = List.map (fun (id0, id1) -> match_regions id0 id1) - (List.combine regions0 regions1) + (List.combine generics0.regions generics1.regions) in - let tys = - List.map (fun (ty0, ty1) -> match_rec ty0 ty1) (List.combine tys0 tys1) + let types = + List.map + (fun (ty0, ty1) -> match_rec ty0 ty1) + (List.combine generics0.types generics1.types) in - Adt (id, regions, tys, cgs) + let generics = { T.regions; types; const_generics; trait_refs } in + Adt (id, generics) | TypeVar vid0, TypeVar vid1 -> assert (vid0 = vid1); let vid = vid0 in diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 04dc8892..2a277c91 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -3,6 +3,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open Cps open ValuesUtils @@ -95,16 +96,14 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) | pe :: p' -> ( (* Match on the projection element and the value *) match (pe, v.V.value, v.V.ty) with - | ( Field (((ProjAdt (_, _) | ProjOption _) as proj_kind), field_id), + | ( Field ((ProjAdt (_, _) as proj_kind), field_id), V.Adt adt, - T.Adt (type_id, _, _, _) ) -> ( + T.Adt (type_id, _) ) -> ( (* Check consistency *) (match (proj_kind, type_id) with | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> assert (def_id = def_id'); assert (opt_variant_id = adt.variant_id) - | ProjOption variant_id, T.Assumed T.Option -> - assert (Some variant_id = adt.variant_id) | _ -> raise (Failure "Unreachable")); (* Actually project *) let fv = T.FieldId.nth adt.field_values field_id in @@ -119,8 +118,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) let updated = { v with value = nadt } in Ok (ctx, { res with updated })) (* Tuples *) - | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _, _, _) - -> ( + | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _) -> ( assert (arity = List.length adt.field_values); let fv = T.FieldId.nth adt.field_values field_id in (* Project *) @@ -136,7 +134,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) Ok (ctx, { res with updated }) (* If we reach Bottom, it may mean we need to expand an uninitialized * enumeration value *)) - | Field ((ProjAdt (_, _) | ProjTuple _ | ProjOption _), _), V.Bottom, _ -> + | Field ((ProjAdt (_, _) | ProjTuple _), _), V.Bottom, _ -> Error (FailBottom (1 + List.length p', pe, v.ty)) (* Symbolic value: needs to be expanded *) | _, Symbolic sp, _ -> @@ -145,9 +143,9 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) (* Box dereferencement *) | ( DerefBox, Adt { variant_id = None; field_values = [ bv ] }, - T.Adt (T.Assumed T.Box, _, _, _) ) -> ( - (* We allow moving inside of boxes. In practice, this kind of - * manipulations should happen only inside unsage code, so + T.Adt (T.Assumed T.Box, _) ) -> ( + (* We allow moving outside of boxes. In practice, this kind of + * manipulations should happen only inside unsafe code, so * it shouldn't happen due to user code, and we leverage it * when implementing box dereferencement for the concrete * interpreter *) @@ -357,45 +355,32 @@ let write_place (access : access_kind) (p : E.place) (nv : V.typed_value) | Error e -> raise (Failure ("Unreachable: " ^ show_path_fail_kind e)) | Ok ctx -> ctx -let compute_expanded_bottom_adt_value (tyctx : T.type_decl T.TypeDeclId.Map.t) +let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.erased_region list) (types : T.ety list) - (cgs : T.const_generic list) : V.typed_value = + (generics : T.egeneric_args) : V.typed_value = (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) - let def = T.TypeDeclId.Map.find def_id tyctx in - assert (List.length regions = List.length def.T.region_params); + let def = C.ctx_lookup_type_decl ctx def_id in + assert (List.length generics.regions = List.length def.T.generics.regions); (* Compute the field types *) let field_types = - Subst.type_decl_get_instantiated_field_etypes def opt_variant_id types cgs + Assoc.type_decl_get_inst_norm_field_etypes ctx def opt_variant_id generics in (* Initialize the expanded value *) let fields = List.map mk_bottom field_types in let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.Adt (T.AdtId def_id, regions, types, cgs) in + let ty = T.Adt (T.AdtId def_id, generics) in { V.value = av; V.ty } -let compute_expanded_bottom_option_value (variant_id : T.VariantId.id) - (param_ty : T.ety) : V.typed_value = - (* Note that the variant can be [Some] or [None]: we expand bottom values - * when writing to fields or setting discriminants *) - let field_values = - if variant_id = T.option_some_id then [ mk_bottom param_ty ] - else if variant_id = T.option_none_id then [] - else raise (Failure "Unreachable") - in - let av = V.Adt { variant_id = Some variant_id; field_values } in - let ty = T.Adt (T.Assumed T.Option, [], [ param_ty ], []) in - { V.value = av; ty } - let compute_expanded_bottom_tuple_value (field_types : T.ety list) : V.typed_value = (* Generate the field values *) let fields = List.map mk_bottom field_types in let v = V.Adt { variant_id = None; field_values = fields } in - let ty = T.Adt (T.Tuple, [], field_types, []) in + let generics = TypesUtils.mk_generic_args [] field_types [] [] in + let ty = T.Adt (T.Tuple, generics) in { V.value = v; V.ty } (** Auxiliary helper to expand {!V.Bottom} values. @@ -447,19 +432,18 @@ let expand_bottom_value_from_projection (access : access_kind) (p : E.place) match (pe, ty) with (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.Adt (T.AdtId def_id', regions, types, cgs) ) -> + T.Adt (T.AdtId def_id', generics) ) -> assert (def_id = def_id'); - compute_expanded_bottom_adt_value ctx.type_context.type_decls def_id - opt_variant_id regions types cgs - (* Option *) - | ( Field (ProjOption variant_id, _), - T.Adt (T.Assumed T.Option, [], [ ty ], []) ) -> - compute_expanded_bottom_option_value variant_id ty + compute_expanded_bottom_adt_value ctx def_id opt_variant_id generics (* Tuples *) - | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys, []) -> - assert (arity = List.length tys); + | ( Field (ProjTuple arity, _), + T.Adt + ( T.Tuple, + { T.regions = []; types; const_generics = []; trait_refs = [] } ) ) + -> + assert (arity = List.length types); (* Generate the field values *) - compute_expanded_bottom_tuple_value tys + compute_expanded_bottom_tuple_value types | _ -> raise (Failure diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index 4a9f3b41..0ff8063f 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -3,6 +3,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open Cps open InterpreterExpansion @@ -56,18 +57,12 @@ val compute_expanded_bottom_tuple_value : T.ety list -> V.typed_value (** Compute an expanded ADT ⊥ value *) val compute_expanded_bottom_adt_value : - T.type_decl T.TypeDeclId.Map.t -> + C.eval_ctx -> T.TypeDeclId.id -> T.VariantId.id option -> - T.erased_region list -> - T.ety list -> - T.const_generic list -> + T.egeneric_args -> V.typed_value -(** Compute an expanded [Option] ⊥ value *) -val compute_expanded_bottom_option_value : - T.VariantId.id -> T.ety -> V.typed_value - (** Drop (end) outer loans at a given place, which should be seen as an l-value (we will write to it later, but need to drop the loans before writing). diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index faed066b..9e0c2b75 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -3,6 +3,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open TypesUtils open InterpreterUtils @@ -24,12 +25,12 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) else match (v.V.value, ty) with | V.Literal _, T.Literal _ -> [] - | V.Adt adt, T.Adt (id, region_params, tys, cgs) -> + | V.Adt adt, T.Adt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys cgs + Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics in + (* Project over the field values *) let fields_types = List.combine adt.V.field_values field_types in let proj_fields = @@ -103,11 +104,10 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) let value : V.avalue = match (v.V.value, ty) with | V.Literal _, T.Literal _ -> V.AIgnored - | V.Adt adt, T.Adt (id, region_params, tys, cgs) -> + | V.Adt adt, T.Adt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys cgs + Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics in (* Project over the field values *) let fields_types = List.combine adt.V.field_values field_types in @@ -268,8 +268,7 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) let (value, ty) : V.avalue * T.rty = match (see, original_sv_ty) with | SeLiteral _, T.Literal _ -> (V.AIgnored, original_sv_ty) - | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys, _cgs) - -> + | SeAdt (variant_id, field_values), T.Adt (_id, _generics) -> (* Project over the field values *) let field_values = List.map diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 045c4484..e0c4703b 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -10,13 +10,13 @@ open TypesUtils open ValuesUtils module Inv = Invariants module S = SynthesizeSymbolic -open Utils open Cps open InterpreterUtils open InterpreterProjectors open InterpreterExpansion open InterpreterPaths open InterpreterExpressions +module PCtx = Print.EvalCtxLlbcAst (** The local logger *) let log = L.statements_log @@ -232,9 +232,7 @@ let set_discriminant (config : C.config) (p : E.place) let update_value cf (v : V.typed_value) : m_fun = fun ctx -> match (v.V.ty, v.V.value) with - | ( T.Adt - (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types, cgs), - V.Adt av ) -> ( + | T.Adt ((T.AdtId _ as type_id), generics), V.Adt av -> ( (* There are two situations: - either the discriminant is already the proper one (in which case we don't do anything) @@ -251,28 +249,17 @@ let set_discriminant (config : C.config) (p : E.place) let bottom_v = match type_id with | T.AdtId def_id -> - compute_expanded_bottom_adt_value - ctx.type_context.type_decls def_id (Some variant_id) - regions types cgs - | T.Assumed T.Option -> - assert (regions = []); - compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil types) + compute_expanded_bottom_adt_value ctx def_id + (Some variant_id) generics | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx) - | ( T.Adt - (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types, cgs), - V.Bottom ) -> + | T.Adt ((T.AdtId _ as type_id), generics), V.Bottom -> let bottom_v = match type_id with | T.AdtId def_id -> - compute_expanded_bottom_adt_value ctx.type_context.type_decls - def_id (Some variant_id) regions types cgs - | T.Assumed T.Option -> - assert (regions = []); - compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil types) + compute_expanded_bottom_adt_value ctx def_id (Some variant_id) + generics | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx @@ -301,24 +288,34 @@ let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) (** Small helper: compute the type of the return value for a specific - instantiation of a non-local function. + instantiation of an assumed function. *) -let get_non_local_function_return_type (fid : A.assumed_fun_id) - (region_params : T.erased_region list) (type_params : T.ety list) - (const_generic_params : T.const_generic list) : T.ety = +let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) + (generics : T.egeneric_args) : T.ety = + assert (generics.trait_refs = []); (* [Box::free] has a special treatment *) - match (fid, region_params, type_params, const_generic_params) with - | A.BoxFree, [], [ _ ], [] -> mk_unit_ty + match fid with + | BoxFree -> + assert (generics.regions = []); + assert (List.length generics.types = 1); + assert (generics.const_generics = []); + mk_unit_ty | _ -> (* Retrieve the function's signature *) - let sg = Assumed.get_assumed_sig fid in + let sg = Assumed.get_assumed_fun_sig fid in (* Instantiate the return type *) - let tsubst = Subst.make_type_subst_from_vars sg.type_params type_params in - let cgsubst = - Subst.make_const_generic_subst_from_vars sg.const_generic_params - const_generic_params + (* There shouldn't be any reference to Self *) + let tr_self : T.erased_region T.trait_instance_id = + T.UnknownTrait __FUNCTION__ + in + let { Subst.r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = + Subst.make_esubst_from_generics sg.generics generics tr_self + in + let ty = + Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self + sg.output in - Subst.erase_regions_substitute_types tsubst cgsubst sg.output + Assoc.ctx_normalize_ety ctx ty let move_return_value (config : C.config) (pop_return_value : bool) (cf : V.typed_value option -> m_fun) : m_fun = @@ -418,19 +415,14 @@ let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = in comp cf_pop cf_assign -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_replace_concrete (_config : C.config) - (_region_params : T.erased_region list) (_type_params : T.ety list) - (_cg_params : T.const_generic list) : cm_fun = - fun _cf _ctx -> raise Unimplemented - -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_box_new_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (cg_params : T.const_generic list) : cm_fun = +(** Auxiliary function - see {!eval_assumed_function_call} *) +let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : + cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) - match (region_params, type_params, cg_params, ctx.env) with + match + (generics.regions, generics.types, generics.const_generics, ctx.env) + with | ( [], [ boxed_ty ], [], @@ -448,7 +440,8 @@ let eval_box_new_concrete (config : C.config) (* Create the new box *) let cf_create cf (moved_input_value : V.typed_value) : m_fun = (* Create the box value *) - let box_ty = T.Adt (T.Assumed T.Box, [], [ boxed_ty ], []) in + let generics = TypesUtils.mk_generic_args_from_types [ boxed_ty ] in + let box_ty = T.Adt (T.Assumed T.Box, generics) in let box_v = V.Adt { variant_id = None; field_values = [ moved_input_value ] } in @@ -466,71 +459,7 @@ let eval_box_new_concrete (config : C.config) comp cf_move cf_create cf ctx | _ -> raise (Failure "Inconsistent state") -(** Auxiliary function which factorizes code to evaluate [std::Deref::deref] - and [std::DerefMut::deref_mut] - see {!eval_non_local_function_call} *) -let eval_box_deref_mut_or_shared_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (cg_params : T.const_generic list) (is_mut : bool) : cm_fun = - fun cf ctx -> - (* Check the arguments *) - match (region_params, type_params, cg_params, ctx.env) with - | ( [], - [ boxed_ty ], - [], - Var (VarBinder input_var, input_value) - :: Var (_ret_var, _) - :: C.Frame :: _ ) -> - (* Required type checking. We must have: - - input_value.ty = & (mut) Box<ty> - - boxed_ty = ty - for some ty - *) - (let _, input_ty, ref_kind = ty_get_ref input_value.V.ty in - assert (match ref_kind with T.Shared -> not is_mut | T.Mut -> is_mut); - let input_ty = ty_get_box input_ty in - assert (input_ty = boxed_ty)); - - (* Borrow the boxed value *) - let p = - { E.var_id = input_var.C.index; projection = [ E.Deref; E.DerefBox ] } - in - let borrow_kind = if is_mut then E.Mut else E.Shared in - let rv = E.Ref (p, borrow_kind) in - let cf_borrow = eval_rvalue_not_global config rv in - - (* Move the borrow to its destination *) - let cf_move cf res : m_fun = - match res with - | Error EPanic -> - (* We can't get there by borrowing a value *) - raise (Failure "Unreachable") - | Ok borrowed_value -> - (* Move and continue *) - let destp = mk_place_from_var_id E.VarId.zero in - assign_to_place config borrowed_value destp cf - in - - (* Compose and apply *) - comp cf_borrow cf_move cf ctx - | _ -> raise (Failure "Inconsistent state") - -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_box_deref_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (cg_params : T.const_generic list) : cm_fun = - let is_mut = false in - eval_box_deref_mut_or_shared_concrete config region_params type_params - cg_params is_mut - -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_box_deref_mut_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (cg_params : T.const_generic list) : cm_fun = - let is_mut = true in - eval_box_deref_mut_or_shared_concrete config region_params type_params - cg_params is_mut - -(** Auxiliary function - see {!eval_non_local_function_call}. +(** Auxiliary function - see {!eval_assumed_function_call}. [Box::free] is not handled the same way as the other assumed functions: - in the regular case, whenever we need to evaluate an assumed function, @@ -549,11 +478,10 @@ let eval_box_deref_mut_concrete (config : C.config) It thus updates the box value (by calling {!drop_value}) and updates the destination (by setting it to [()]). *) -let eval_box_free (config : C.config) (region_params : T.erased_region list) - (type_params : T.ety list) (cg_params : T.const_generic list) +let eval_box_free (config : C.config) (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : cm_fun = fun cf ctx -> - match (region_params, type_params, cg_params, args) with + match (generics.regions, generics.types, generics.const_generics, args) with | [], [ boxed_ty ], [], [ E.Move input_box_place ] -> (* Required type checking *) let input_box = InterpreterPaths.read_place Write input_box_place ctx in @@ -570,26 +498,24 @@ let eval_box_free (config : C.config) (region_params : T.erased_region list) cc cf ctx | _ -> raise (Failure "Inconsistent state") -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_vec_function_concrete (_config : C.config) (_fid : A.assumed_fun_id) - (_region_params : T.erased_region list) (_type_params : T.ety list) - (_cg_params : T.const_generic list) : cm_fun = - fun _cf _ctx -> raise Unimplemented - (** Evaluate a non-local function call in concrete mode *) -let eval_non_local_function_call_concrete (config : C.config) - (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (cg_params : T.const_generic list) - (args : E.operand list) (dest : E.place) : cm_fun = +let eval_assumed_function_call_concrete (config : C.config) + (fid : A.assumed_fun_id) (call : A.call) : cm_fun = + let generics = call.func.generics in + let args = call.args in + let dest = call.dest in + (* Sanity check: we don't fully handle the const generic vars environment + in concrete mode yet *) + assert (generics.const_generics = []); (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free See {!eval_box_free} *) match fid with - | A.BoxFree -> + | BoxFree -> (* Degenerate case: box_free *) - eval_box_free config region_params type_params cg_params args dest + eval_box_free config generics args dest | _ -> (* "Normal" case: not box_free *) (* Evaluate the operands *) @@ -604,16 +530,14 @@ let eval_non_local_function_call_concrete (config : C.config) * but it made it less clear where the computed values came from, * so we reversed the modifications. *) let cf_eval_call cf (args_vl : V.typed_value list) : m_fun = + fun ctx -> (* Push the stack frame: we initialize the frame with the return variable, and one variable per input argument *) let cc = push_frame in (* Create and push the return variable *) let ret_vid = E.VarId.zero in - let ret_ty = - get_non_local_function_return_type fid region_params type_params - cg_params - in + let ret_ty = get_assumed_function_return_type ctx fid generics in let ret_var = mk_var ret_vid (Some "@return") ret_ty in let cc = comp cc (push_uninitialized_var ret_var) in @@ -630,24 +554,12 @@ let eval_non_local_function_call_concrete (config : C.config) * access to a body. *) let cf_eval_body : cm_fun = match fid with - | A.Replace -> - eval_replace_concrete config region_params type_params cg_params - | BoxNew -> - eval_box_new_concrete config region_params type_params cg_params - | BoxDeref -> - eval_box_deref_concrete config region_params type_params cg_params - | BoxDerefMut -> - eval_box_deref_mut_concrete config region_params type_params - cg_params + | BoxNew -> eval_box_new_concrete config generics | BoxFree -> (* Should have been treated above *) raise (Failure "Unreachable") - | VecNew | VecPush | VecInsert | VecLen | VecIndex | VecIndexMut -> - eval_vec_function_concrete config fid region_params type_params - cg_params | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared - | ArrayToSliceMut | ArraySubsliceShared | ArraySubsliceMut - | SliceIndexShared | SliceIndexMut | SliceSubsliceShared - | SliceSubsliceMut | SliceLen -> + | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut + | SliceLen -> raise (Failure "Unimplemented") in @@ -657,50 +569,11 @@ let eval_non_local_function_call_concrete (config : C.config) let cc = comp cc (pop_frame_assign config dest) in (* Continue *) - cc cf + cc cf ctx in (* Compose and apply *) comp cf_eval_ops cf_eval_call -let instantiate_fun_sig (type_params : T.ety list) - (cg_params : T.const_generic list) (sg : A.fun_sig) : A.inst_fun_sig = - (* Generate fresh abstraction ids and create a substitution from region - * group ids to abstraction ids *) - let rg_abs_ids_bindings = - List.map - (fun rg -> - let abs_id = C.fresh_abstraction_id () in - (rg.T.id, abs_id)) - sg.regions_hierarchy - in - let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = - List.fold_left - (fun mp (rg_id, abs_id) -> T.RegionGroupId.Map.add rg_id abs_id mp) - T.RegionGroupId.Map.empty rg_abs_ids_bindings - in - let asubst (rg_id : T.RegionGroupId.id) : V.AbstractionId.id = - T.RegionGroupId.Map.find rg_id asubst_map - in - (* Generate fresh regions and their substitutions *) - let _, rsubst, _ = Subst.fresh_regions_with_substs sg.region_params in - (* Generate the type substitution - * Note that we need the substitution to map the type variables to - * {!rty} types (not {!ety}). In order to do that, we convert the - * type parameters to types with regions. This is possible only - * if those types don't contain any regions. - * This is a current limitation of the analysis: there is still some - * work to do to properly handle full type parametrization. - * *) - let rtype_params = List.map ety_no_regions_to_rty type_params in - let tsubst = Subst.make_type_subst_from_vars sg.type_params rtype_params in - let cgsubst = - Subst.make_const_generic_subst_from_vars sg.const_generic_params cg_params - in - (* Substitute the signature *) - let inst_sig = Subst.substitute_signature asubst rsubst tsubst cgsubst sg in - (* Return *) - inst_sig - (** Helper Create abstractions (with no avalues, which have to be inserted afterwards) @@ -836,7 +709,7 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = match rvalue with | E.Global _ -> raise (Failure "Unreachable") | E.Use _ - | E.Ref (_, (E.Shared | E.Mut | E.TwoPhaseMut | E.Shallow)) + | E.RvRef (_, (E.Shared | E.Mut | E.TwoPhaseMut | E.Shallow)) | E.UnaryOp _ | E.BinaryOp _ | E.Discriminant _ | E.Aggregate _ -> let rp = rvalue_get_place rvalue in @@ -893,7 +766,15 @@ and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) match config.mode with | ConcreteMode -> (* Treat the evaluation of the global as a call to the global body (without arguments) *) - (eval_local_function_call_concrete config global.body_id [] [] [] [] dest) + let func = + { + E.func = FunId (Regular global.body_id); + generics = TypesUtils.mk_empty_generic_args; + trait_and_method_generic_args = None; + } + in + let call = { A.func; args = []; dest } in + (eval_transparent_function_call_concrete config global.body_id call) cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be @@ -1037,128 +918,374 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = (** Evaluate a function call (auxiliary helper for [eval_statement]) *) and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = - (* There are two cases: + (* There are several cases: - this is a local function, in which case we execute its body - - this is a non-local function, in which case there is a special treatment + - this is an assumed function, in which case there is a special treatment + - this is a trait method *) - match call.func with - | A.Regular fid -> - eval_local_function_call config fid call.region_args call.type_args - call.const_generic_args call.args call.dest - | A.Assumed fid -> - eval_non_local_function_call config fid call.region_args call.type_args - call.const_generic_args call.args call.dest + match config.mode with + | C.ConcreteMode -> eval_function_call_concrete config call + | C.SymbolicMode -> eval_function_call_symbolic config call -(** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) - (_region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : - st_cm_fun = +and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun + = fun cf ctx -> - (* Retrieve the (correctly instantiated) body *) - let def = C.ctx_lookup_fun_decl ctx fid in - (* We can evaluate the function call only if it is not opaque *) - let body = - match def.body with - | None -> - raise - (Failure - ("Can't evaluate a call to an opaque function: " - ^ Print.name_to_string def.name)) - | Some body -> body - in - let tsubst = - Subst.make_type_subst_from_vars def.A.signature.type_params type_args - in - let cgsubst = - Subst.make_const_generic_subst_from_vars - def.A.signature.const_generic_params cg_args - in - let locals, body_st = Subst.fun_body_substitute_in_body tsubst cgsubst body in - - (* Evaluate the input operands *) - assert (List.length args = body.A.arg_count); - let cc = eval_operands config args in - - (* Push a frame delimiter - we use {!comp_transmit} to transmit the result - * of the operands evaluation from above to the functions afterwards, while - * ignoring it in this function *) - let cc = comp_transmit cc push_frame in - - (* Compute the initial values for the local variables *) - (* 1. Push the return value *) - let ret_var, locals = - match locals with - | ret_ty :: locals -> (ret_ty, locals) - | _ -> raise (Failure "Unreachable") - in - let input_locals, locals = - Collections.List.split_at locals body.A.arg_count - in + match call.func.func with + | FunId (Regular fid) -> + eval_transparent_function_call_concrete config fid call cf ctx + | FunId (Assumed fid) -> + (* Continue - note that we do as if the function call has been successful, + * by giving {!Unit} to the continuation, because we place us in the case + * where we haven't panicked. Of course, the translation needs to take the + * panic case into account... *) + eval_assumed_function_call_concrete config fid call (cf Unit) ctx + | TraitMethod _ -> raise (Failure "Unimplemented") + +and eval_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun + = + match call.func.func with + | FunId (Regular _) | TraitMethod _ -> + eval_transparent_function_call_symbolic config call + | FunId (Assumed fid) -> eval_assumed_function_call_symbolic config fid call - let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in - - (* 2. Push the input values *) - let cf_push_inputs cf args = - let inputs = List.combine input_locals args in - (* Note that this function checks that the variables and their values - * have the same type (this is important) *) - push_vars inputs cf - in - let cc = comp cc cf_push_inputs in - - (* 3. Push the remaining local variables (initialized as {!Bottom}) *) - let cc = comp cc (push_uninitialized_vars locals) in +(** Evaluate a local (i.e., non-assumed) function call in concrete mode *) +and eval_transparent_function_call_concrete (config : C.config) + (fid : A.FunDeclId.id) (call : A.call) : st_cm_fun = + let generics = call.func.generics in + let args = call.A.args in + let dest = call.A.dest in + (* Sanity check: we don't fully handle the const generic vars environment + in concrete mode yet *) + assert (generics.const_generics = []); + fun cf ctx -> + (* Retrieve the (correctly instantiated) body *) + let def = C.ctx_lookup_fun_decl ctx fid in + (* We can evaluate the function call only if it is not opaque *) + let body = + match def.body with + | None -> + raise + (Failure + ("Can't evaluate a call to an opaque function: " + ^ Print.name_to_string def.name)) + | Some body -> body + in + (* TODO: we need to normalize the types if we want to correctly support traits *) + assert (generics.trait_refs = []); + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = + Subst.make_esubst_from_generics def.A.signature.generics generics tr_self + in + let locals, body_st = Subst.fun_body_substitute_in_body subst body in + + (* Evaluate the input operands *) + assert (List.length args = body.A.arg_count); + let cc = eval_operands config args in + + (* Push a frame delimiter - we use {!comp_transmit} to transmit the result + * of the operands evaluation from above to the functions afterwards, while + * ignoring it in this function *) + let cc = comp_transmit cc push_frame in + + (* Compute the initial values for the local variables *) + (* 1. Push the return value *) + let ret_var, locals = + match locals with + | ret_ty :: locals -> (ret_ty, locals) + | _ -> raise (Failure "Unreachable") + in + let input_locals, locals = + Collections.List.split_at locals body.A.arg_count + in - (* Execute the function body *) - let cc = comp cc (eval_function_body config body_st) in + let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in - (* Pop the stack frame and move the return value to its destination *) - let cf_finish cf res = - match res with - | Panic -> cf Panic - | Return -> - (* Pop the stack frame, retrieve the return value, move it to - * its destination and continue *) - pop_frame_assign config dest (cf Unit) - | Break _ | Continue _ | Unit | LoopReturn _ | EndEnterLoop _ - | EndContinue _ -> - raise (Failure "Unreachable") - in - let cc = comp cc cf_finish in + (* 2. Push the input values *) + let cf_push_inputs cf args = + let inputs = List.combine input_locals args in + (* Note that this function checks that the variables and their values + * have the same type (this is important) *) + push_vars inputs cf + in + let cc = comp cc cf_push_inputs in + + (* 3. Push the remaining local variables (initialized as {!Bottom}) *) + let cc = comp cc (push_uninitialized_vars locals) in + + (* Execute the function body *) + let cc = comp cc (eval_function_body config body_st) in + + (* Pop the stack frame and move the return value to its destination *) + let cf_finish cf res = + match res with + | Panic -> cf Panic + | Return -> + (* Pop the stack frame, retrieve the return value, move it to + * its destination and continue *) + pop_frame_assign config dest (cf Unit) + | Break _ | Continue _ | Unit | LoopReturn _ | EndEnterLoop _ + | EndContinue _ -> + raise (Failure "Unreachable") + in + let cc = comp cc cf_finish in - (* Continue *) - cc cf ctx + (* Continue *) + cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) - (region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : - st_cm_fun = +and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) + : st_cm_fun = fun cf ctx -> - (* Retrieve the (correctly instantiated) signature *) - let def = C.ctx_lookup_fun_decl ctx fid in - let sg = def.A.signature in - (* Instantiate the signature and introduce fresh abstraction and region ids - * while doing so *) - let inst_sg = instantiate_fun_sig type_args cg_args sg in + (* Instantiate the signature and introduce fresh abstractions and region ids while doing so. + + We perform some manipulations when instantiating the signature. + + # Trait impl calls + ================== + In particular, we have a special treatment of trait method calls when + the trait ref is a known impl. + + For instance: + {[ + trait HasValue { + fn has_value(&self) -> bool; + } + + impl<T> HasValue for Option<T> { + fn has_value(&self) { + match self { + None => false, + Some(_) => true, + } + } + } + + fn option_has_value<T>(x: &Option<T>) -> bool { + x.has_value() + } + ]} + + The generated code looks like this: + {[ + structure HasValue (Self : Type) = { + has_value : Self -> result bool + } + + let OptionHasValueImpl.has_value (Self : Type) (self : Self) : result bool = + match self with + | None => false + | Some _ => true + + let OptionHasValueInstance (T : Type) : HasValue (Option T) = { + has_value = OptionHasValueInstance.has_value + } + ]} + + In [option_has_value], we don't want to refer to the [has_value] method + of the instance of [HasValue] for [Option<T>]. We want to refer directly + to the function which implements [has_value] for [Option<T>]. + That is, instead of generating this: + {[ + let option_has_value (T : Type) (x : Option T) : result bool = + (OptionHasValueInstance T).has_value x + ]} + + We want to generate this: + {[ + let option_has_value (T : Type) (x : Option T) : result bool = + OptionHasValueImpl.has_value T x + ]} + + # Provided trait methods + ======================== + Calls to provided trait methods also have a special treatment because + for now we forbid overriding provided trait methods in the trait implementations, + which means that whenever we call a provided trait method, we do not refer + to a trait clause but directly to the method provided in the trait declaration. + *) + let func, generics, def, inst_sg = + match call.func.func with + | FunId (Regular fid) -> + let def = C.ctx_lookup_fun_decl ctx fid in + log#ldebug + (lazy + ("fun call:\n- call: " ^ call_to_string ctx call + ^ "\n- call.generics:\n" + ^ egeneric_args_to_string ctx call.func.generics + ^ "\n- def.signature:\n" + ^ fun_sig_to_string ctx def.A.signature)); + let tr_self = T.UnknownTrait __FUNCTION__ in + let inst_sg = + instantiate_fun_sig ctx call.func.generics tr_self def.A.signature + in + (call.func.func, call.func.generics, def, inst_sg) + | FunId (Assumed _) -> + (* Unreachable: must be a transparent function *) + raise (Failure "Unreachable") + | TraitMethod (trait_ref, method_name, _) -> ( + log#ldebug + (lazy + ("trait method call:\n- call: " ^ call_to_string ctx call + ^ "\n- method name: " ^ method_name ^ "\n- call.generics:\n" + ^ egeneric_args_to_string ctx call.func.generics + ^ "\n- trait and method generics:\n" + ^ egeneric_args_to_string ctx + (Option.get call.func.trait_and_method_generic_args))); + (* When instantiating, we need to group the generics for the trait ref + and the method *) + let generics = Option.get call.func.trait_and_method_generic_args in + (* Lookup the trait method signature - there are several possibilities + depending on whethere we call a top-level trait method impl or the + method from a local clause *) + match trait_ref.trait_id with + | TraitImpl impl_id -> ( + (* Lookup the trait impl *) + let trait_impl = C.ctx_lookup_trait_impl ctx impl_id in + log#ldebug + (lazy ("trait impl: " ^ trait_impl_to_string ctx trait_impl)); + (* First look in the required methods *) + let method_id = + List.find_opt + (fun (s, _) -> s = method_name) + trait_impl.required_methods + in + match method_id with + | Some (_, id) -> + (* This is a required method *) + let method_def = C.ctx_lookup_fun_decl ctx id in + (* Instantiate *) + let tr_self = + T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) + in + let inst_sg = + instantiate_fun_sig ctx generics tr_self + method_def.A.signature + in + (* Also update the function identifier: we want to forget + the fact that we called a trait method, and treat it as + a regular function call to the top-level function + which implements the method. In order to do this properly, + we also need to update the generics. + *) + let func = E.FunId (Regular id) in + (func, generics, method_def, inst_sg) + | None -> + (* If not found, lookup the methods provided by the trait *declaration* + (remember: for now, we forbid overriding provided methods) *) + assert (trait_impl.provided_methods = []); + let trait_decl = + C.ctx_lookup_trait_decl ctx + trait_ref.trait_decl_ref.trait_decl_id + in + let _, method_id = + List.find + (fun (s, _) -> s = method_name) + trait_decl.provided_methods + in + let method_id = Option.get method_id in + let method_def = C.ctx_lookup_fun_decl ctx method_id in + (* For the instantiation we have to do something peculiar + because the method was defined for the trait declaration. + We have to group: + - the parameters given to the trait decl reference + - the parameters given to the method itself + For instance: + {[ + trait Foo<T> { + fn f<U>(...) { ... } + } + + fn g<G>(x : G) where Clause0: Foo<G, bool> + { + x.f::<u32>(...) // The arguments to f are: <G, bool, u32> + } + ]} + *) + let all_generics = + TypesUtils.merge_generic_args + trait_ref.trait_decl_ref.decl_generics call.func.generics + in + log#ldebug + (lazy + ("provided method call:" ^ "\n- method name: " ^ method_name + ^ "\n- all_generics:\n" + ^ egeneric_args_to_string ctx all_generics + ^ "\n- parent params info: " + ^ Print.option_to_string A.show_params_info + method_def.signature.parent_params_info)); + let tr_self = + T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) + in + let inst_sg = + instantiate_fun_sig ctx all_generics tr_self + method_def.A.signature + in + (call.func.func, call.func.generics, method_def, inst_sg)) + | _ -> + (* We are using a local clause - we lookup the trait decl *) + let trait_decl = + C.ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id + in + (* Lookup the method decl in the required *and* the provided methods *) + let _, method_id = + let provided = + List.filter_map + (fun (id, f) -> + match f with None -> None | Some f -> Some (id, f)) + trait_decl.provided_methods + in + List.find + (fun (s, _) -> s = method_name) + (List.append trait_decl.required_methods provided) + in + let method_def = C.ctx_lookup_fun_decl ctx method_id in + log#ldebug (lazy ("method:\n" ^ fun_decl_to_string ctx method_def)); + (* Instantiate *) + let tr_self = T.TraitRef trait_ref in + let tr_self = + TypesUtils.etrait_instance_id_no_regions_to_gr_trait_instance_id + tr_self + in + let inst_sg = + instantiate_fun_sig ctx generics tr_self method_def.A.signature + in + (call.func.func, call.func.generics, method_def, inst_sg)) + in (* Sanity check *) - assert (List.length args = List.length def.A.signature.inputs); + assert (List.length call.args = List.length def.A.signature.inputs); (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (A.Regular fid) inst_sg - region_args type_args cg_args args dest cf ctx + eval_function_call_symbolic_from_inst_sig config func inst_sg generics + call.args call.dest cf ctx (** Evaluate a function call in symbolic mode by using the function signature. This allows us to factorize the evaluation of local and non-local function calls in symbolic mode: only their signatures matter. + + The [self_trait_ref] trait ref refers to [Self]. We use it when calling + a provided trait method, because those methods have a special treatment: + we dot not group them with the required trait methods, and forbid (for now) + overriding them. We treat them as regular method, which take an additional + trait ref as input. *) and eval_function_call_symbolic_from_inst_sig (config : C.config) - (fid : A.fun_id) (inst_sg : A.inst_fun_sig) - (_region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : + (fid : A.fun_id_or_trait_method_ref) (inst_sg : A.inst_fun_sig) + (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> + log#ldebug + (lazy + ("eval_function_call_symbolic_from_inst_sig:\n- fid: " + ^ fun_id_or_trait_method_ref_to_string ctx fid + ^ "\n- inst_sg:\n" + ^ inst_fun_sig_to_string ctx inst_sg + ^ "\n- call.generics:\n" + ^ egeneric_args_to_string ctx generics + ^ "\n- args:\n" + ^ String.concat ", " (List.map (operand_to_string ctx) args) + ^ "\n- dest:\n" ^ place_to_string ctx dest)); + (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.A.output in let ret_spc = mk_fresh_symbolic_value V.FunCallRet ret_sv_ty in @@ -1224,8 +1351,8 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) let expr = cf ctx in (* Synthesize the symbolic AST *) - S.synthesize_regular_function_call fid call_id ctx abs_ids type_args cg_args - args args_places ret_spc dest_place expr + S.synthesize_regular_function_call fid call_id ctx abs_ids generics args + args_places ret_spc dest_place expr in let cc = comp cc cf_call in @@ -1286,17 +1413,18 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) cc (cf Unit) ctx (** Evaluate a non-local function call in symbolic mode *) -and eval_non_local_function_call_symbolic (config : C.config) - (fid : A.assumed_fun_id) (region_args : T.erased_region list) - (type_args : T.ety list) (cg_args : T.const_generic list) - (args : E.operand list) (dest : E.place) : st_cm_fun = +and eval_assumed_function_call_symbolic (config : C.config) + (fid : A.assumed_fun_id) (call : A.call) : st_cm_fun = fun cf ctx -> + let generics = call.func.generics in + let args = call.args in + let dest = call.dest in (* Sanity check: make sure the type parameters don't contain regions - * this is a current limitation of our synthesis *) assert ( List.for_all (fun ty -> not (ty_has_borrows ctx.type_context.type_infos ty)) - type_args); + generics.types); (* There are two cases (and this is extremely annoying): - the function is not box_free @@ -1304,10 +1432,10 @@ and eval_non_local_function_call_symbolic (config : C.config) See {!eval_box_free} *) match fid with - | A.BoxFree -> + | BoxFree -> (* Degenerate case: box_free - note that this is not really a function * call: no need to call a "synthesize_..." function *) - eval_box_free config region_args type_args cg_args args dest (cf Unit) ctx + eval_box_free config generics args dest (cf Unit) ctx | _ -> (* "Normal" case: not box_free *) (* In symbolic mode, the behaviour of a function call is completely defined @@ -1315,59 +1443,19 @@ and eval_non_local_function_call_symbolic (config : C.config) * instantiated signatures, and delegate the work to an auxiliary function *) let inst_sig = match fid with - | A.BoxFree -> + | BoxFree -> (* should have been treated above *) raise (Failure "Unreachable") | _ -> - instantiate_fun_sig type_args cg_args (Assumed.get_assumed_sig fid) + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + instantiate_fun_sig ctx generics tr_self + (Assumed.get_assumed_fun_sig fid) in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (A.Assumed fid) inst_sig - region_args type_args cg_args args dest cf ctx - -(** Evaluate a non-local (i.e, assumed) function call such as [Box::deref] - (auxiliary helper for [eval_statement]) *) -and eval_non_local_function_call (config : C.config) (fid : A.assumed_fun_id) - (region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : - st_cm_fun = - fun cf ctx -> - (* Debug *) - log#ldebug - (lazy - (let type_args = - "[" ^ String.concat ", " (List.map (ety_to_string ctx) type_args) ^ "]" - in - let args = - "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" - in - let dest = place_to_string ctx dest in - "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid - ^ "\n- type_args: " ^ type_args ^ "\n- args: " ^ args ^ "\n- dest: " - ^ dest)); - - match config.mode with - | C.ConcreteMode -> - eval_non_local_function_call_concrete config fid region_args type_args - cg_args args dest (cf Unit) ctx - | C.SymbolicMode -> - eval_non_local_function_call_symbolic config fid region_args type_args - cg_args args dest cf ctx - -(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for - [eval_statement]) *) -and eval_local_function_call (config : C.config) (fid : A.FunDeclId.id) - (region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : - st_cm_fun = - match config.mode with - | ConcreteMode -> - eval_local_function_call_concrete config fid region_args type_args cg_args - args dest - | SymbolicMode -> - eval_local_function_call_symbolic config fid region_args type_args cg_args - args dest + eval_function_call_symbolic_from_inst_sig config (FunId (Assumed fid)) + inst_sig generics args dest cf ctx (** Evaluate a statement seen as a function body *) and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index 814bc964..e65758ae 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -25,15 +25,6 @@ open InterpreterExpressions *) val pop_frame : C.config -> bool -> (V.typed_value option -> m_fun) -> m_fun -(** Instantiate a function signature, introducing **fresh** abstraction ids and - region ids. This is mostly used in preparation of function calls, when - evaluating in symbolic mode of course. - - Note: there are no region parameters, because they should be erased. - *) -val instantiate_fun_sig : - T.ety list -> T.const_generic list -> LA.fun_sig -> LA.inst_fun_sig - (** Helper. Create a list of abstractions from a list of regions groups, and insert diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 7bd37550..6e08e553 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -10,6 +10,11 @@ open TypesUtils module PA = Print.EvalCtxLlbcAst open Cps +(* TODO: we should probably rename the file to ContextsUtils *) + +(** The local logger *) +let log = L.interpreter_log + (** Some utilities *) (** Auxiliary function - call a function which requires a continuation, @@ -38,6 +43,20 @@ let typed_value_to_string = PA.typed_value_to_string let typed_avalue_to_string = PA.typed_avalue_to_string let place_to_string = PA.place_to_string let operand_to_string = PA.operand_to_string +let egeneric_args_to_string = PA.egeneric_args_to_string +let rtrait_instance_id_to_string = PA.rtrait_instance_id_to_string +let fun_sig_to_string = PA.fun_sig_to_string +let inst_fun_sig_to_string = PA.inst_fun_sig_to_string + +let fun_id_or_trait_method_ref_to_string = + PA.fun_id_or_trait_method_ref_to_string + +let fun_decl_to_string = PA.fun_decl_to_string +let call_to_string = PA.call_to_string + +let trait_impl_to_string ctx = + PA.trait_impl_to_string { ctx with type_vars = []; const_generic_vars = [] } + let statement_to_string ctx = PA.statement_to_string ctx "" " " let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " let env_elem_to_string ctx = PA.env_elem_to_string ctx "" " " @@ -255,7 +274,8 @@ let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) raise Found else () | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack - | V.SynthRetGivenBack | V.Global | V.LoopGivenBack | V.Aggregate -> + | V.SynthRetGivenBack | V.Global | V.LoopGivenBack | V.Aggregate + | V.ConstGeneric | V.TraitConst -> () end in @@ -272,7 +292,7 @@ let rvalue_get_place (rv : E.rvalue) : E.place option = match rv with | Use (Copy p | Move p) -> Some p | Use (Constant _) -> None - | Ref (p, _) -> Some p + | RvRef (p, _) -> Some p | UnaryOp _ | BinaryOp _ | Global _ | Discriminant _ | Aggregate _ -> None (** See {!ValuesUtils.symbolic_value_has_borrows} *) @@ -403,3 +423,103 @@ let compute_contexts_ids (ctxl : C.eval_ctx list) : ids_sets * ids_to_values = (** Compute the sets of ids found in a context. *) let compute_context_ids (ctx : C.eval_ctx) : ids_sets * ids_to_values = compute_contexts_ids [ ctx ] + +(** **WARNING**: this function doesn't compute the normalized types + (for the trait type aliases). This should be computed afterwards. + *) +let initialize_eval_context (ctx : C.decls_ctx) + (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) + (const_generic_vars : T.const_generic_var list) : C.eval_ctx = + C.reset_global_counters (); + let const_generic_vars_map = + T.ConstGenericVarId.Map.of_list + (List.map + (fun (cg : T.const_generic_var) -> + let ty = TypesUtils.ety_no_regions_to_rty (T.Literal cg.ty) in + let cv = mk_fresh_symbolic_typed_value V.ConstGeneric ty in + (cg.index, cv)) + const_generic_vars) + in + { + C.type_context = ctx.type_ctx; + C.fun_context = ctx.fun_ctx; + C.global_context = ctx.global_ctx; + C.trait_decls_context = ctx.trait_decls_ctx; + C.trait_impls_context = ctx.trait_impls_ctx; + C.region_groups; + C.type_vars; + C.const_generic_vars; + C.const_generic_vars_map; + C.norm_trait_etypes = C.ETraitTypeRefMap.empty (* Empty for now *); + C.norm_trait_rtypes = C.RTraitTypeRefMap.empty (* Empty for now *); + C.norm_trait_stypes = C.STraitTypeRefMap.empty (* Empty for now *); + C.env = [ C.Frame ]; + C.ended_regions = T.RegionId.Set.empty; + } + +(** Instantiate a function signature, introducing **fresh** abstraction ids and + region ids. This is mostly used in preparation of function calls (when + evaluating in symbolic mode). + + Note: there are no region parameters, because they should be erased. + *) +let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) + (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + log#ldebug + (lazy + ("instantiate_fun_sig:" ^ "\n- generics: " + ^ egeneric_args_to_string ctx generics + ^ "\n- tr_self: " + ^ rtrait_instance_id_to_string ctx tr_self + ^ "\n- sg: " ^ fun_sig_to_string ctx sg)); + (* Generate fresh abstraction ids and create a substitution from region + * group ids to abstraction ids *) + let rg_abs_ids_bindings = + List.map + (fun rg -> + let abs_id = C.fresh_abstraction_id () in + (rg.T.id, abs_id)) + sg.regions_hierarchy + in + let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = + List.fold_left + (fun mp (rg_id, abs_id) -> T.RegionGroupId.Map.add rg_id abs_id mp) + T.RegionGroupId.Map.empty rg_abs_ids_bindings + in + let asubst (rg_id : T.RegionGroupId.id) : V.AbstractionId.id = + T.RegionGroupId.Map.find rg_id asubst_map + in + (* Generate fresh regions and their substitutions *) + let _, rsubst, _ = Subst.fresh_regions_with_substs sg.generics.regions in + (* Generate the type substitution + * Note that we need the substitution to map the type variables to + * {!rty} types (not {!ety}). In order to do that, we convert the + * type parameters to types with regions. This is possible only + * if those types don't contain any regions. + * This is a current limitation of the analysis: there is still some + * work to do to properly handle full type parametrization. + * *) + let rtype_params = List.map ety_no_regions_to_rty generics.types in + let tsubst = Subst.make_type_subst_from_vars sg.generics.types rtype_params in + let cgsubst = + Subst.make_const_generic_subst_from_vars sg.generics.const_generics + generics.const_generics + in + (* TODO: something annoying with the trait ref subst: we need to use region + types, but the arguments use erased regions. For now we use the fact + that no regions should appear inside. In the future: we should merge + ety and rty. *) + let trait_refs = + List.map TypesUtils.etrait_ref_no_regions_to_gr_trait_ref + generics.trait_refs + in + let tr_subst = + Subst.make_trait_subst_from_clauses sg.generics.trait_clauses trait_refs + in + (* Substitute the signature *) + let inst_sig = + AssociatedTypes.ctx_subst_norm_signature ctx asubst rsubst tsubst cgsubst + tr_subst tr_self sg + in + (* Return *) + inst_sig diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index f29c7f88..5c8ec7af 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -7,6 +7,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module A = LlbcAst module L = Logging open Cps @@ -406,13 +407,14 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (match (tv.V.value, tv.V.ty) with | V.Literal cv, T.Literal ty -> check_literal_type cv ty (* ADT case *) - | V.Adt av, T.Adt (T.AdtId def_id, regions, tys, cgs) -> + | V.Adt av, T.Adt (T.AdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - assert (List.length regions = List.length def.region_params); - assert (List.length tys = List.length def.type_params); + assert ( + List.length generics.regions = List.length def.generics.regions); + assert (List.length generics.types = List.length def.generics.types); (* Check that the variant id is consistent *) (match (av.V.variant_id, def.T.kind) with | Some variant_id, T.Enum variants -> @@ -421,8 +423,8 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Subst.type_decl_get_instantiated_field_etypes def av.V.variant_id - tys cgs + Assoc.type_decl_get_inst_norm_field_etypes ctx def av.V.variant_id + generics in let fields_with_types = List.combine av.V.field_values field_types @@ -431,34 +433,31 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.Adt av, T.Adt (T.Tuple, regions, tys, cgs) -> - assert (regions = []); - assert (cgs = []); + | V.Adt av, T.Adt (T.Tuple, generics) -> + assert (generics.regions = []); + assert (generics.const_generics = []); assert (av.V.variant_id = None); (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) - let fields_with_types = List.combine av.V.field_values tys in + let fields_with_types = + List.combine av.V.field_values generics.types + in List.iter (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) fields_with_types (* Assumed type case *) - | V.Adt av, T.Adt (T.Assumed aty_id, regions, tys, cgs) -> ( - assert (av.V.variant_id = None || aty_id = T.Option); - match (aty_id, av.V.field_values, regions, tys, cgs) with + | V.Adt av, T.Adt (T.Assumed aty_id, generics) -> ( + assert (av.V.variant_id = None); + match + ( aty_id, + av.V.field_values, + generics.regions, + generics.types, + generics.const_generics ) + with (* Box *) - | T.Box, [ inner_value ], [], [ inner_ty ], [] - | T.Option, [ inner_value ], [], [ inner_ty ], [] -> + | T.Box, [ inner_value ], [], [ inner_ty ], [] -> assert (inner_value.V.ty = inner_ty) - | T.Option, _, [], [ _ ], [] -> - (* Option::None: nothing to check *) - () - | T.Vec, fvs, [], [ vec_ty ], [] -> - List.iter - (fun (v : V.typed_value) -> assert (v.ty = vec_ty)) - fvs - | T.Range, [ v0; v1 ], [], [ inner_ty ], [] -> - assert (v0.V.ty = inner_ty); - assert (v1.V.ty = inner_ty) | T.Array, inner_values, _, [ inner_ty ], [ cg ] -> (* *) assert ( @@ -520,14 +519,17 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Check the current pair (value, type) *) (match (atv.V.value, atv.V.ty) with (* ADT case *) - | V.AAdt av, T.Adt (T.AdtId def_id, regions, tys, cgs) -> + | V.AAdt av, T.Adt (T.AdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - assert (List.length regions = List.length def.region_params); - assert (List.length tys = List.length def.type_params); - assert (List.length cgs = List.length def.const_generic_params); + assert ( + List.length generics.regions = List.length def.generics.regions); + assert (List.length generics.types = List.length def.generics.types); + assert ( + List.length generics.const_generics + = List.length def.generics.const_generics); (* Check that the variant id is consistent *) (match (av.V.variant_id, def.T.kind) with | Some variant_id, T.Enum variants -> @@ -536,8 +538,8 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Subst.type_decl_get_instantiated_field_rtypes def av.V.variant_id - regions tys cgs + Assoc.type_decl_get_inst_norm_field_rtypes ctx def av.V.variant_id + generics in let fields_with_types = List.combine av.V.field_values field_types @@ -546,20 +548,28 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.AAdt av, T.Adt (T.Tuple, regions, tys, cgs) -> - assert (regions = []); - assert (cgs = []); + | V.AAdt av, T.Adt (T.Tuple, generics) -> + assert (generics.regions = []); + assert (generics.const_generics = []); assert (av.V.variant_id = None); (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) - let fields_with_types = List.combine av.V.field_values tys in + let fields_with_types = + List.combine av.V.field_values generics.types + in List.iter (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) fields_with_types (* Assumed type case *) - | V.AAdt av, T.Adt (T.Assumed aty_id, regions, tys, cgs) -> ( + | V.AAdt av, T.Adt (T.Assumed aty_id, generics) -> ( assert (av.V.variant_id = None); - match (aty_id, av.V.field_values, regions, tys, cgs) with + match + ( aty_id, + av.V.field_values, + generics.regions, + generics.types, + generics.const_generics ) + with (* Box *) | T.Box, [ boxed_value ], [], [ boxed_ty ], [] -> assert (boxed_value.V.ty = boxed_ty) diff --git a/compiler/LlbcAst.ml b/compiler/LlbcAst.ml index f4d26e18..2db859b2 100644 --- a/compiler/LlbcAst.ml +++ b/compiler/LlbcAst.ml @@ -11,6 +11,7 @@ type abs_region_groups = (AbstractionId.id, RegionId.id) g_region_groups (** A function signature, after instantiation *) type inst_fun_sig = { regions_hierarchy : abs_region_groups; + trait_type_constraints : rtrait_type_constraint list; inputs : rty list; output : rty; } diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index 1111c297..0ab4ed94 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -5,10 +5,46 @@ let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : fun_sig = match fun_id with | Regular id -> (FunDeclId.Map.find id fun_decls).signature - | Assumed aid -> Assumed.get_assumed_sig aid + | Assumed aid -> Assumed.get_assumed_fun_sig aid let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : Names.fun_name = match fun_id with | Regular id -> (FunDeclId.Map.find id fun_decls).name - | Assumed aid -> Assumed.get_assumed_name aid + | Assumed aid -> Assumed.get_assumed_fun_name aid + +(** Return the opaque declarations found in the crate, which are also *not builtin*. + + [filter_assumed]: if [true], do not consider as opaque the external definitions + that we will map to definitions from the standard library. + + Remark: the list of functions also contains the list of opaque global bodies. + *) +let crate_get_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : + T.type_decl list * fun_decl list = + let open ExtractBuiltin in + let is_opaque_fun (d : fun_decl) : bool = + let sname = name_to_simple_name d.name in + d.body = None + (* Something to pay attention to: we must ignore trait method *declarations* + (which don't have a body but must not be considered as opaque) *) + && (match d.kind with TraitMethodDecl _ -> false | _ -> true) + && ((not filter_assumed) + || (not (SimpleNameMap.mem sname builtin_globals_map)) + && not (SimpleNameMap.mem sname (builtin_funs_map ()))) + in + let is_opaque_type (d : T.type_decl) : bool = + let sname = name_to_simple_name d.name in + d.kind = T.Opaque + && ((not filter_assumed) + || not (SimpleNameMap.mem sname (builtin_types_map ()))) + in + (* Note that by checking the function bodies we also the globals *) + ( List.filter is_opaque_type (T.TypeDeclId.Map.values k.types), + List.filter is_opaque_fun (FunDeclId.Map.values k.functions) ) + +(** Return true if the crate contains opaque declarations, ignoring the assumed + definitions. *) +let crate_has_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : + bool = + crate_get_opaque_non_builtin_decls k filter_assumed <> ([], []) diff --git a/compiler/Logging.ml b/compiler/Logging.ml index 9dc1f5e3..721655b8 100644 --- a/compiler/Logging.ml +++ b/compiler/Logging.ml @@ -9,6 +9,9 @@ let pre_passes_log = L.get_logger "MainLogger.PrePasses" (** Logger for Translate *) let translate_log = L.get_logger "MainLogger.Translate" +(** Logger for Contexts *) +let contexts_log = L.get_logger "MainLogger.Contexts" + (** Logger for PureUtils *) let pure_utils_log = L.get_logger "MainLogger.PureUtils" @@ -19,7 +22,7 @@ let symbolic_to_pure_log = L.get_logger "MainLogger.SymbolicToPure" let pure_micro_passes_log = L.get_logger "MainLogger.PureMicroPasses" (** Logger for ExtractBase *) -let pure_to_extract_log = L.get_logger "MainLogger.ExtractBase" +let extract_log = L.get_logger "MainLogger.ExtractBase" (** Logger for Interpreter *) let interpreter_log = L.get_logger "MainLogger.Interpreter" @@ -57,6 +60,9 @@ let borrows_log = L.get_logger "MainLogger.Interpreter.Borrows" (** Logger for Invariants *) let invariants_log = L.get_logger "MainLogger.Interpreter.Invariants" +(** Logger for AssociatedTypes *) +let associated_types_log = L.get_logger "MainLogger.AssociatedTypes" + (** Logger for SCC *) let scc_log = L.get_logger "MainLogger.Graph.SCC" diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index b348ba1d..ee06fa07 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -107,8 +107,8 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = false | Assign (_, rv) -> ( match rv with - | Use _ | Ref _ -> not must_end_with_exit - | Aggregate (AggregatedTuple, []) -> not must_end_with_exit + | Use _ | RvRef _ -> not must_end_with_exit + | Aggregate (AggregatedAdt (Tuple, _, _), []) -> not must_end_with_exit | _ -> false) | FakeRead _ | Drop _ | Nop -> not must_end_with_exit | Panic | Return -> true @@ -376,7 +376,7 @@ let remove_shallow_borrows (crate : A.crate) (f : A.fun_decl) : A.fun_decl = method! visit_Assign env p rv = match (p.projection, rv) with - | [], E.Ref (_, E.Shallow) -> + | [], E.RvRef (_, E.Shallow) -> (* Filter *) filtered := E.VarId.Set.add p.var_id !filtered; Nop diff --git a/compiler/Print.ml b/compiler/Print.ml index 9aa73d7c..7f0d95ff 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -21,6 +21,9 @@ module Values = struct type_decl_id_to_string : T.TypeDeclId.id -> string; const_generic_var_id_to_string : T.ConstGenericVarId.id -> string; global_decl_id_to_string : T.GlobalDeclId.id -> string; + trait_decl_id_to_string : T.TraitDeclId.id -> string; + trait_impl_id_to_string : T.TraitImplId.id -> string; + trait_clause_id_to_string : T.TraitClauseId.id -> string; adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; var_id_to_string : E.VarId.id -> string; adt_field_names : @@ -34,6 +37,9 @@ module Values = struct PT.type_decl_id_to_string = fmt.type_decl_id_to_string; PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; PT.global_decl_id_to_string = fmt.global_decl_id_to_string; + PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; + PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; + PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let value_to_rtype_formatter (fmt : value_formatter) : PT.rtype_formatter = @@ -43,6 +49,9 @@ module Values = struct PT.type_decl_id_to_string = fmt.type_decl_id_to_string; PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; PT.global_decl_id_to_string = fmt.global_decl_id_to_string; + PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; + PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; + PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let value_to_stype_formatter (fmt : value_formatter) : PT.stype_formatter = @@ -52,6 +61,9 @@ module Values = struct PT.type_decl_id_to_string = fmt.type_decl_id_to_string; PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; PT.global_decl_id_to_string = fmt.global_decl_id_to_string; + PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; + PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; + PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let var_id_to_string (id : E.VarId.id) : string = @@ -86,10 +98,10 @@ module Values = struct List.map (typed_value_to_string fmt) av.field_values in match v.ty with - | T.Adt (T.Tuple, _, _, _) -> + | T.Adt (T.Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _, _, _) -> + | T.Adt (T.AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -111,21 +123,10 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.Adt (T.Assumed aty, _, _, _) -> ( + | T.Adt (T.Assumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with | Box, [ bv ] -> "@Box(" ^ bv ^ ")" - | Option, _ -> - if av.variant_id = Some T.option_some_id then - "@Option::Some(" - ^ Collections.List.to_cons_nil field_values - ^ ")" - else if av.variant_id = Some T.option_none_id then ( - assert (field_values = []); - "@Option::None") - else raise (Failure "Unreachable") - | Range, _ -> "@Range{ " ^ String.concat ", " field_values ^ "}" - | Vec, _ -> "@Vec[" ^ String.concat ", " field_values ^ "]" | Array, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" @@ -201,10 +202,10 @@ module Values = struct List.map (typed_avalue_to_string fmt) av.field_values in match v.ty with - | T.Adt (T.Tuple, _, _, _) -> + | T.Adt (T.Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _, _, _) -> + | T.Adt (T.AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -226,7 +227,7 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.Adt (T.Assumed aty, _, _, _) -> ( + | T.Adt (T.Assumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with | Box, [ bv ] -> "@Box(" ^ bv ^ ")" @@ -347,6 +348,18 @@ module Values = struct ^ "}" ^ "{regions=" ^ T.RegionId.Set.to_string None abs.regions ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" + + let inst_fun_sig_to_string (fmt : value_formatter) (sg : LlbcAst.inst_fun_sig) + : string = + (* TODO: print the trait type constraints? *) + let ty_fmt = value_to_rtype_formatter fmt in + let ty_to_string = PT.ty_to_string ty_fmt in + + let inputs = + "(" ^ String.concat ", " (List.map ty_to_string sg.inputs) ^ ")" + in + let output = ty_to_string sg.output in + inputs ^ " -> " ^ output end module PV = Values (* local module *) @@ -452,6 +465,9 @@ module Contexts = struct PV.adt_variant_to_string = fmt.adt_variant_to_string; PV.var_id_to_string = fmt.var_id_to_string; PV.adt_field_names = fmt.adt_field_names; + PV.trait_decl_id_to_string = fmt.trait_decl_id_to_string; + PV.trait_impl_id_to_string = fmt.trait_impl_id_to_string; + PV.trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let ast_to_value_formatter (fmt : PA.ast_formatter) : PV.value_formatter = @@ -463,20 +479,27 @@ module Contexts = struct let ctx_to_rtype_formatter (fmt : ctx_formatter) : PT.rtype_formatter = PV.value_to_rtype_formatter fmt + let ctx_to_stype_formatter (fmt : ctx_formatter) : PT.stype_formatter = + PV.value_to_stype_formatter fmt + let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = - (* We shouldn't use rvar_to_string *) - let rvar_to_string _r = - raise (Failure "Unexpected use of rvar_to_string") + let rvar_to_string r = + (* In theory we shouldn't use rvar_to_string, but it can happen + when printing definitions for instance... *) + T.RegionVarId.to_string r in let r_to_string r = PT.region_id_to_string r in let type_var_id_to_string vid = - let v = C.lookup_type_var ctx vid in - v.name + (* The context may be invalid *) + match C.lookup_type_var_opt ctx vid with + | None -> T.TypeVarId.to_string vid + | Some v -> v.name in let const_generic_var_id_to_string vid = - let v = C.lookup_const_generic_var ctx vid in - v.name + match C.lookup_const_generic_var_opt ctx vid with + | None -> T.ConstGenericVarId.to_string vid + | Some v -> v.name in let type_decl_id_to_string def_id = let def = C.ctx_lookup_type_decl ctx def_id in @@ -486,6 +509,15 @@ module Contexts = struct let def = C.ctx_lookup_global_decl ctx def_id in name_to_string def.name in + let trait_decl_id_to_string def_id = + let def = C.ctx_lookup_trait_decl ctx def_id in + name_to_string def.name + in + let trait_impl_id_to_string def_id = + let def = C.ctx_lookup_trait_impl ctx def_id in + name_to_string def.name + in + let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in let adt_variant_to_string = PT.type_ctx_to_adt_variant_to_string_fun ctx.type_context.type_decls in @@ -506,6 +538,9 @@ module Contexts = struct adt_variant_to_string; var_id_to_string; adt_field_names; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; } let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : PA.ast_formatter = @@ -521,6 +556,15 @@ module Contexts = struct let def = C.ctx_lookup_global_decl ctx def_id in global_name_to_string def.name in + let trait_decl_id_to_string def_id = + let def = C.ctx_lookup_trait_decl ctx def_id in + name_to_string def.name + in + let trait_impl_id_to_string def_id = + let def = C.ctx_lookup_trait_impl ctx def_id in + name_to_string def.name + in + let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in { rvar_to_string = ctx_fmt.PV.rvar_to_string; r_to_string = ctx_fmt.PV.r_to_string; @@ -533,6 +577,9 @@ module Contexts = struct adt_field_to_string; fun_decl_id_to_string; global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; } (** Split an [env] at every occurrence of [Frame], eliminating those elements. @@ -608,6 +655,68 @@ module EvalCtxLlbcAst = struct let fmt = PC.ctx_to_rtype_formatter fmt in PT.rty_to_string fmt t + let sty_to_string (ctx : C.eval_ctx) (t : T.sty) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.sty_to_string fmt t + + let generic_params_to_strings (ctx : C.eval_ctx) (x : T.generic_params) : + string list * string list = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.generic_params_to_strings fmt x + + let egeneric_args_to_string (ctx : C.eval_ctx) (x : T.egeneric_args) : string + = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_etype_formatter fmt in + PT.egeneric_args_to_string fmt x + + let rgeneric_args_to_string (ctx : C.eval_ctx) (x : T.rgeneric_args) : string + = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PT.rgeneric_args_to_string fmt x + + let sgeneric_args_to_string (ctx : C.eval_ctx) (x : T.sgeneric_args) : string + = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.sgeneric_args_to_string fmt x + + let etrait_ref_to_string (ctx : C.eval_ctx) (x : T.etrait_ref) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_etype_formatter fmt in + PT.etrait_ref_to_string fmt x + + let rtrait_ref_to_string (ctx : C.eval_ctx) (x : T.rtrait_ref) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PT.rtrait_ref_to_string fmt x + + let strait_ref_to_string (ctx : C.eval_ctx) (x : T.strait_ref) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.strait_ref_to_string fmt x + + let etrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.etrait_instance_id) + : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_etype_formatter fmt in + PT.etrait_instance_id_to_string fmt x + + let rtrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.rtrait_instance_id) + : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PT.rtrait_instance_id_to_string fmt x + + let strait_instance_id_to_string (ctx : C.eval_ctx) (x : T.strait_instance_id) + : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.strait_instance_id_to_string fmt x + let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in @@ -653,11 +762,38 @@ module EvalCtxLlbcAst = struct let fmt = PC.eval_ctx_to_ast_formatter ctx in PE.operand_to_string fmt op + let call_to_string (ctx : C.eval_ctx) (call : A.call) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PA.call_to_string fmt "" call + + let fun_decl_to_string (ctx : C.eval_ctx) (f : A.fun_decl) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PA.fun_decl_to_string fmt "" " " f + + let fun_sig_to_string (ctx : C.eval_ctx) (x : A.fun_sig) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PA.fun_sig_to_string fmt "" " " x + + let inst_fun_sig_to_string (ctx : C.eval_ctx) (x : LlbcAst.inst_fun_sig) : + string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + let fmt = PC.ast_to_value_formatter fmt in + PV.inst_fun_sig_to_string fmt x + + let fun_id_or_trait_method_ref_to_string (ctx : C.eval_ctx) + (x : E.fun_id_or_trait_method_ref) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PE.fun_id_or_trait_method_ref_to_string fmt x "..." + let statement_to_string (ctx : C.eval_ctx) (indent : string) (indent_incr : string) (e : A.statement) : string = let fmt = PC.eval_ctx_to_ast_formatter ctx in PA.statement_to_string fmt indent indent_incr e + let trait_impl_to_string (ctx : C.eval_ctx) (timpl : A.trait_impl) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PA.trait_impl_to_string fmt " " " " timpl + let env_elem_to_string (ctx : C.eval_ctx) (indent : string) (indent_incr : string) (ev : C.env_elem) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index cfb63ec2..ec75fcfd 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -8,6 +8,9 @@ type type_formatter = { type_decl_id_to_string : TypeDeclId.id -> string; const_generic_var_id_to_string : ConstGenericVarId.id -> string; global_decl_id_to_string : GlobalDeclId.id -> string; + trait_decl_id_to_string : TraitDeclId.id -> string; + trait_impl_id_to_string : TraitImplId.id -> string; + trait_clause_id_to_string : TraitClauseId.id -> string; } type value_formatter = { @@ -18,6 +21,9 @@ type value_formatter = { adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; var_id_to_string : VarId.id -> string; adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; + trait_decl_id_to_string : TraitDeclId.id -> string; + trait_impl_id_to_string : TraitImplId.id -> string; + trait_clause_id_to_string : TraitClauseId.id -> string; } let value_to_type_formatter (fmt : value_formatter) : type_formatter = @@ -26,6 +32,9 @@ let value_to_type_formatter (fmt : value_formatter) : type_formatter = type_decl_id_to_string = fmt.type_decl_id_to_string; const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; global_decl_id_to_string = fmt.global_decl_id_to_string; + trait_decl_id_to_string = fmt.trait_decl_id_to_string; + trait_impl_id_to_string = fmt.trait_impl_id_to_string; + trait_clause_id_to_string = fmt.trait_clause_id_to_string; } (* TODO: we need to store which variables we have encountered so far, and @@ -42,6 +51,9 @@ type ast_formatter = { adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; fun_decl_id_to_string : FunDeclId.id -> string; global_decl_id_to_string : GlobalDeclId.id -> string; + trait_decl_id_to_string : TraitDeclId.id -> string; + trait_impl_id_to_string : TraitImplId.id -> string; + trait_clause_id_to_string : TraitClauseId.id -> string; } let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = @@ -53,6 +65,9 @@ let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = adt_variant_to_string = fmt.adt_variant_to_string; var_id_to_string = fmt.var_id_to_string; adt_field_names = fmt.adt_field_names; + trait_decl_id_to_string = fmt.trait_decl_id_to_string; + trait_impl_id_to_string = fmt.trait_impl_id_to_string; + trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let ast_to_type_formatter (fmt : ast_formatter) : type_formatter = @@ -70,31 +85,51 @@ let literal_type_to_string = Print.PrimitiveValues.literal_type_to_string let scalar_value_to_string = Print.PrimitiveValues.scalar_value_to_string let literal_to_string = Print.PrimitiveValues.literal_to_string +(* Remark: not using generic_params on purpose, because we may use parameters + which either come from LLBC or from pure, and the [generic_params] type + for those ASTs is not the same. Note that it works because we actually don't + need to know the trait clauses to print the AST: we can thus ignore them. +*) let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) (global_decls : A.global_decl GlobalDeclId.Map.t) - (type_params : type_var list) + (trait_decls : A.trait_decl TraitDeclId.Map.t) + (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) (const_generic_params : const_generic_var list) : type_formatter = let type_var_id_to_string vid = - let var = T.TypeVarId.nth type_params vid in + let var = TypeVarId.nth type_params vid in type_var_to_string var in let const_generic_var_id_to_string vid = - let var = T.ConstGenericVarId.nth const_generic_params vid in + let var = ConstGenericVarId.nth const_generic_params vid in const_generic_var_to_string var in let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in + let def = TypeDeclId.Map.find def_id type_decls in name_to_string def.name in let global_decl_id_to_string def_id = - let def = T.GlobalDeclId.Map.find def_id global_decls in + let def = GlobalDeclId.Map.find def_id global_decls in + name_to_string def.name + in + let trait_decl_id_to_string def_id = + let def = TraitDeclId.Map.find def_id trait_decls in + name_to_string def.name + in + let trait_impl_id_to_string def_id = + let def = TraitImplId.Map.find def_id trait_impls in name_to_string def.name in + let trait_clause_id_to_string id = + Print.PT.trait_clause_id_to_pretty_string id + in { type_var_id_to_string; type_decl_id_to_string; const_generic_var_id_to_string; global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; } (* TODO: there is a bit of duplication with Print.fun_decl_to_ast_formatter. @@ -106,19 +141,21 @@ let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) (fun_decls : A.fun_decl FunDeclId.Map.t) (global_decls : A.global_decl GlobalDeclId.Map.t) - (type_params : type_var list) + (trait_decls : A.trait_decl TraitDeclId.Map.t) + (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) (const_generic_params : const_generic_var list) : ast_formatter = - let type_var_id_to_string vid = - let var = T.TypeVarId.nth type_params vid in - type_var_to_string var - in - let const_generic_var_id_to_string vid = - let var = T.ConstGenericVarId.nth const_generic_params vid in - const_generic_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in - name_to_string def.name + let ({ + type_var_id_to_string; + type_decl_id_to_string; + const_generic_var_id_to_string; + global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; + } + : type_formatter) = + mk_type_formatter type_decls global_decls trait_decls trait_impls + type_params const_generic_params in let adt_variant_to_string = Print.Types.type_ctx_to_adt_variant_to_string_fun type_decls @@ -137,10 +174,6 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) let def = FunDeclId.Map.find def_id fun_decls in fun_name_to_string def.name in - let global_decl_id_to_string def_id = - let def = GlobalDeclId.Map.find def_id global_decls in - global_name_to_string def.name - in { type_var_id_to_string; const_generic_var_id_to_string; @@ -151,6 +184,9 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) adt_field_to_string; fun_decl_id_to_string; global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; } let assumed_ty_to_string (aty : assumed_ty) : string = @@ -159,12 +195,11 @@ let assumed_ty_to_string (aty : assumed_ty) : string = | Result -> "Result" | Error -> "Error" | Fuel -> "Fuel" - | Option -> "Option" - | Vec -> "Vec" | Array -> "Array" | Slice -> "Slice" | Str -> "Str" - | Range -> "Range" + | RawPtr Mut -> "MutRawPtr" + | RawPtr Const -> "ConstRawPtr" let type_id_to_string (fmt : type_formatter) (id : type_id) : string = match id with @@ -182,20 +217,18 @@ let const_generic_to_string (fmt : type_formatter) (cg : T.const_generic) : let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = match ty with - | Adt (id, tys, cgs) -> ( - let tys = List.map (ty_to_string fmt false) tys in - let cgs = List.map (const_generic_to_string fmt) cgs in - let params = List.append tys cgs in + | Adt (id, generics) -> ( match id with | Tuple -> - assert (cgs = []); - "(" ^ String.concat " * " tys ^ ")" + let generics = generic_args_to_strings fmt false generics in + "(" ^ String.concat " * " generics ^ ")" | AdtId _ | Assumed _ -> - let params_s = - if params = [] then "" else " " ^ String.concat " " params + let generics = generic_args_to_strings fmt true generics in + let generics_s = + if generics = [] then "" else " " ^ String.concat " " generics in - let ty_s = type_id_to_string fmt id ^ params_s in - if params <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) + let ty_s = type_id_to_string fmt id ^ generics_s in + if generics <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) | TypeVar tv -> fmt.type_var_id_to_string tv | Literal lty -> literal_type_to_string lty | Arrow (arg_ty, ret_ty) -> @@ -203,6 +236,71 @@ let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = ty_to_string fmt true arg_ty ^ " -> " ^ ty_to_string fmt false ret_ty in if inside then "(" ^ ty ^ ")" else ty + | TraitType (trait_ref, generics, type_name) -> + let trait_ref = trait_ref_to_string fmt false trait_ref in + let s = + if generics = empty_generic_args then trait_ref ^ "::" ^ type_name + else + let generics = generic_args_to_string fmt generics in + "(" ^ trait_ref ^ " " ^ generics ^ ")::" ^ type_name + in + if inside then "(" ^ s ^ ")" else s + +and generic_args_to_strings (fmt : type_formatter) (inside : bool) + (generics : generic_args) : string list = + let tys = List.map (ty_to_string fmt inside) generics.types in + let cgs = List.map (const_generic_to_string fmt) generics.const_generics in + let trait_refs = + List.map (trait_ref_to_string fmt inside) generics.trait_refs + in + List.concat [ tys; cgs; trait_refs ] + +and generic_args_to_string (fmt : type_formatter) (generics : generic_args) : + string = + String.concat " " (generic_args_to_strings fmt true generics) + +and trait_ref_to_string (fmt : type_formatter) (inside : bool) (tr : trait_ref) + : string = + let trait_id = trait_instance_id_to_string fmt false tr.trait_id in + let generics = generic_args_to_string fmt tr.generics in + let s = trait_id ^ generics in + if tr.generics = empty_generic_args || not inside then s else "(" ^ s ^ ")" + +and trait_instance_id_to_string (fmt : type_formatter) (inside : bool) + (id : trait_instance_id) : string = + match id with + | Self -> "Self" + | TraitImpl id -> fmt.trait_impl_id_to_string id + | Clause id -> fmt.trait_clause_id_to_string id + | ParentClause (inst_id, _decl_id, clause_id) -> + let inst_id = trait_instance_id_to_string fmt false inst_id in + let clause_id = fmt.trait_clause_id_to_string clause_id in + "parent(" ^ inst_id ^ ")::" ^ clause_id + | ItemClause (inst_id, _decl_id, item_name, clause_id) -> + let inst_id = trait_instance_id_to_string fmt false inst_id in + let clause_id = fmt.trait_clause_id_to_string clause_id in + "(" ^ inst_id ^ ")::" ^ item_name ^ "::[" ^ clause_id ^ "]" + | TraitRef tr -> trait_ref_to_string fmt inside tr + | UnknownTrait msg -> "UNKNOWN(" ^ msg ^ ")" + +let trait_clause_to_string (fmt : type_formatter) (clause : trait_clause) : + string = + let clause_id = fmt.trait_clause_id_to_string clause.clause_id in + let trait_id = fmt.trait_decl_id_to_string clause.trait_id in + let generics = generic_args_to_strings fmt true clause.generics in + let generics = + if generics = [] then "" else " " ^ String.concat " " generics + in + "[" ^ clause_id ^ "]: " ^ trait_id ^ generics + +let generic_params_to_strings (fmt : type_formatter) (generics : generic_params) + : string list = + let tys = List.map type_var_to_string generics.types in + let cgs = List.map const_generic_var_to_string generics.const_generics in + let trait_clauses = + List.map (trait_clause_to_string fmt) generics.trait_clauses + in + List.concat [ tys; cgs; trait_clauses ] let field_to_string fmt inside (f : field) : string = match f.field_name with @@ -217,11 +315,10 @@ let variant_to_string fmt (v : variant) : string = ^ ")" let type_decl_to_string (fmt : type_formatter) (def : type_decl) : string = - let types = def.type_params in let name = name_to_string def.name in let params = - if types = [] then "" - else " " ^ String.concat " " (List.map type_var_to_string types) + if def.generics = empty_generic_params then "" + else " " ^ String.concat " " (generic_params_to_strings fmt def.generics) in match def.kind with | Struct fields -> @@ -256,10 +353,6 @@ let rec mprojection_to_string (fmt : ast_formatter) (inside : string) | pe :: p' -> ( let s = mprojection_to_string fmt inside p' in match pe.pkind with - | E.ProjOption variant_id -> - assert (variant_id = T.option_some_id); - assert (pe.field_id = T.FieldId.zero); - "(" ^ s ^ "as Option::Some)." ^ T.FieldId.to_string pe.field_id | E.ProjTuple _ -> "(" ^ s ^ ")." ^ T.FieldId.to_string pe.field_id | E.ProjAdt (adt_id, opt_variant_id) -> ( let field_name = @@ -294,11 +387,9 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) | Assumed aty -> ( (* Assumed type *) match aty with - | State | Array | Slice | Str -> + | State | Array | Slice | Str | RawPtr _ -> (* Those types are opaque: we can't get there *) raise (Failure "Unreachable") - | Vec -> "@Vec" - | Range -> "@Range" | Result -> let variant_id = Option.get variant_id in if variant_id = result_return_id then "@Result::Return" @@ -314,13 +405,7 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then "@Fuel::Zero" else if variant_id = fuel_succ_id then "@Fuel::Succ" - else raise (Failure "Unreachable: improper variant id for fuel type") - | Option -> - let variant_id = Option.get variant_id in - if variant_id = option_some_id then "@Option::Some " - else if variant_id = option_none_id then "@Option::None" - else - raise (Failure "Unreachable: improper variant id for result type")) + else raise (Failure "Unreachable: improper variant id for fuel type")) let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) (field_id : FieldId.id) : string = @@ -337,11 +422,10 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) | Assumed aty -> ( (* Assumed type *) match aty with - | Range -> FieldId.to_string field_id - | State | Fuel | Vec | Array | Slice | Str -> + | State | Fuel | Array | Slice | Str -> (* Opaque types: we can't get there *) raise (Failure "Unreachable") - | Result | Error | Option -> + | Result | Error | RawPtr _ -> (* Enumerations: we can't get there *) raise (Failure "Unreachable")) @@ -353,10 +437,10 @@ let adt_g_value_to_string (fmt : value_formatter) (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in match ty with - | Adt (Tuple, _, _) -> + | Adt (Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | Adt (AdtId def_id, _, _) -> + | Adt (AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match variant_id with @@ -378,10 +462,10 @@ let adt_g_value_to_string (fmt : value_formatter) let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | Adt (Assumed aty, _, _) -> ( + | Adt (Assumed aty, _) -> ( (* Assumed type *) match aty with - | State -> + | State | RawPtr _ -> (* This type is opaque: we can't get there *) raise (Failure "Unreachable") | Result -> @@ -412,31 +496,13 @@ let adt_g_value_to_string (fmt : value_formatter) | [ v ] -> "@Fuel::Succ " ^ v | _ -> raise (Failure "@Fuel::Succ takes exactly one value") else raise (Failure "Unreachable: improper variant id for fuel type") - | Option -> - let variant_id = Option.get variant_id in - if variant_id = option_some_id then - match field_values with - | [ v ] -> "@Option::Some " ^ v - | _ -> raise (Failure "Option::Some takes exactly one value") - else if variant_id = option_none_id then ( - assert (field_values = []); - "@Option::None") - else - raise (Failure "Unreachable: improper variant id for result type") - | Vec | Array | Slice | Str -> + | Array | Slice | Str -> assert (variant_id = None); let field_values = List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values in let id = assumed_ty_to_string aty in - id ^ " [" ^ String.concat "; " field_values ^ "]" - | Range -> - assert (variant_id = None); - let field_values = - List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values - in - let id = assumed_ty_to_string aty in - id ^ " {" ^ String.concat "; " field_values ^ "}") + id ^ " [" ^ String.concat "; " field_values ^ "]") | _ -> let fmt = value_to_type_formatter fmt in raise @@ -464,10 +530,10 @@ let rec typed_pattern_to_string (fmt : ast_formatter) (v : typed_pattern) : let fun_sig_to_string (fmt : ast_formatter) (sg : fun_sig) : string = let ty_fmt = ast_to_type_formatter fmt in - let type_params = List.map type_var_to_string sg.type_params in + let generics = generic_params_to_strings ty_fmt sg.generics in let inputs = List.map (ty_to_string ty_fmt false) sg.inputs in let output = ty_to_string ty_fmt false sg.output in - let all_types = List.concat [ type_params; inputs; [ output ] ] in + let all_types = List.concat [ generics; inputs; [ output ] ] in String.concat " -> " all_types let inst_fun_sig_to_string (fmt : ast_formatter) (sg : inst_fun_sig) : string = @@ -495,28 +561,16 @@ let fun_suffix (lp_id : LoopId.id option) (rg_id : T.RegionGroupId.id option) : let llbc_assumed_fun_id_to_string (fid : A.assumed_fun_id) : string = match fid with - | A.Replace -> "core::mem::replace" - | A.BoxNew -> "alloc::boxed::Box::new" - | A.BoxDeref -> "core::ops::deref::Deref::deref" - | A.BoxDerefMut -> "core::ops::deref::DerefMut::deref_mut" - | A.BoxFree -> "alloc::alloc::box_free" - | A.VecNew -> "alloc::vec::Vec::new" - | A.VecPush -> "alloc::vec::Vec::push" - | A.VecInsert -> "alloc::vec::Vec::insert" - | A.VecLen -> "alloc::vec::Vec::len" - | A.VecIndex -> "core::ops::index::Index<alloc::vec::Vec>::index" - | A.VecIndexMut -> "core::ops::index::IndexMut<alloc::vec::Vec>::index_mut" + | BoxNew -> "alloc::boxed::Box::new" + | BoxFree -> "alloc::alloc::box_free" | ArrayIndexShared -> "@ArrayIndexShared" | ArrayIndexMut -> "@ArrayIndexMut" | ArrayToSliceShared -> "@ArrayToSliceShared" | ArrayToSliceMut -> "@ArrayToSliceMut" - | ArraySubsliceShared -> "@ArraySubsliceShared" - | ArraySubsliceMut -> "@ArraySubsliceMut" + | ArrayRepeat -> "@ArrayRepeat" | SliceLen -> "@SliceLen" | SliceIndexShared -> "@SliceIndexShared" | SliceIndexMut -> "@SliceIndexMut" - | SliceSubsliceShared -> "@SliceSubsliceShared" - | SliceSubsliceMut -> "@SliceSubsliceMut" let pure_assumed_fun_id_to_string (fid : pure_assumed_fun_id) : string = match fid with @@ -531,8 +585,11 @@ let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = | FromLlbc (fid, lp_id, rg_id) -> let f = match fid with - | Regular fid -> fmt.fun_decl_id_to_string fid - | Assumed fid -> llbc_assumed_fun_id_to_string fid + | FunId (Regular fid) -> fmt.fun_decl_id_to_string fid + | FunId (Assumed fid) -> llbc_assumed_fun_id_to_string fid + | TraitMethod (trait_ref, method_name, _) -> + let fmt = ast_to_type_formatter fmt in + trait_ref_to_string fmt true trait_ref ^ "." ^ method_name in f ^ fun_suffix lp_id rg_id | Pure fid -> pure_assumed_fun_id_to_string fid @@ -559,9 +616,8 @@ let fun_or_op_id_to_string (fmt : ast_formatter) (fun_id : fun_or_op_id) : let rec texpression_to_string (fmt : ast_formatter) (inside : bool) (indent : string) (indent_incr : string) (e : texpression) : string = match e.e with - | Var var_id -> - let s = fmt.var_id_to_string var_id in - if inside then "(" ^ s ^ ")" else s + | Var var_id -> fmt.var_id_to_string var_id + | CVar cg_id -> fmt.const_generic_var_id_to_string cg_id | Const cv -> literal_to_string cv | App _ -> (* Recursively destruct the app, to have a pair (app, arguments list) *) @@ -632,10 +688,11 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) (* There are two possibilities: either the [app] is an instantiated, * top-level qualifier (function, ADT constructore...), or it is a "regular" * expression *) - let app, tys = + let app, generics = match app.e with | Qualif qualif -> (* Qualifier case *) + let ty_fmt = ast_to_type_formatter fmt in (* Convert the qualifier identifier *) let qualif_s = match qualif.id with @@ -654,12 +711,17 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) let field_s = adt_field_to_string value_fmt adt_id field_id in (* Adopting an F*-like syntax *) ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s + | TraitConst (trait_ref, generics, const_name) -> + let trait_ref = trait_ref_to_string ty_fmt true trait_ref in + let generics_s = generic_args_to_string ty_fmt generics in + if generics <> empty_generic_args then + "(" ^ trait_ref ^ generics_s ^ ")." ^ const_name + else trait_ref ^ "." ^ const_name in (* Convert the type instantiation *) - let ty_fmt = ast_to_type_formatter fmt in - let tys = List.map (ty_to_string ty_fmt true) qualif.type_args in + let generics = generic_args_to_strings ty_fmt true qualif.generics in (* *) - (qualif_s, tys) + (qualif_s, generics) | _ -> (* "Regular" expression case *) let inside = args <> [] || (args = [] && inside) in @@ -674,7 +736,7 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) texpression_to_string fmt inside indent1 indent_incr in let args = List.map arg_to_string args in - let all_args = List.append tys args in + let all_args = List.append generics args in (* Put together *) let e = if all_args = [] then app else app ^ " " ^ String.concat " " all_args diff --git a/compiler/Pure.ml b/compiler/Pure.ml index ac4ca081..e6a3dab5 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -13,6 +13,9 @@ module FieldId = T.FieldId module SymbolicValueId = V.SymbolicValueId module FunDeclId = A.FunDeclId module GlobalDeclId = A.GlobalDeclId +module TraitDeclId = T.TraitDeclId +module TraitImplId = T.TraitImplId +module TraitClauseId = T.TraitClauseId (** We redefine identifiers for loop: in {!Values}, the identifiers are global (they monotonically increase across functions) while in {!module:Pure} we want @@ -21,8 +24,6 @@ module GlobalDeclId = A.GlobalDeclId module LoopId = IdGen () -type loop_id = LoopId.id [@@deriving show, ord] - (** We give an identifier to every phase of the synthesis (forward, backward for group of regions 0, etc.) *) module SynthPhaseId = @@ -37,6 +38,16 @@ module ConstGenericVarId = T.ConstGenericVarId type integer_type = T.integer_type [@@deriving show, ord] type const_generic_var = T.const_generic_var [@@deriving show, ord] type const_generic = T.const_generic [@@deriving show, ord] +type const_generic_var_id = T.const_generic_var_id [@@deriving show, ord] +type trait_decl_id = T.trait_decl_id [@@deriving show, ord] +type trait_impl_id = T.trait_impl_id [@@deriving show, ord] +type trait_clause_id = T.trait_clause_id [@@deriving show, ord] +type trait_item_name = T.trait_item_name [@@deriving show, ord] +type global_decl_id = T.global_decl_id [@@deriving show, ord] +type fun_decl_id = A.fun_decl_id [@@deriving show, ord] +type loop_id = LoopId.id [@@deriving show, ord] +type region_group_id = T.region_group_id [@@deriving show, ord] +type mutability = Mut | Const [@@deriving show, ord] (** The assumed types for the pure AST. @@ -59,12 +70,17 @@ type assumed_ty = | Result | Error | Fuel - | Vec - | Option | Array | Slice | Str - | Range + | RawPtr of mutability + (** The bool + Raw pointers don't make sense in the pure world, but we don't know + how to translate them yet and we have to handle some functions which + use raw pointers in their signature (for instance some trait declarations + for the slices). For now, we use a dedicated type to "mark" the raw pointers, + and make sure that those functions are actually not used in the translation. + *) [@@deriving show, ord] (* TODO: we should never directly manipulate [Return] and [Fail], but rather @@ -176,6 +192,14 @@ class ['self] iter_ty_base = inherit! [_] T.iter_const_generic inherit! [_] PV.iter_literal_type method visit_type_var_id : 'env -> type_var_id -> unit = fun _ _ -> () + method visit_trait_decl_id : 'env -> trait_decl_id -> unit = fun _ _ -> () + method visit_trait_impl_id : 'env -> trait_impl_id -> unit = fun _ _ -> () + + method visit_trait_clause_id : 'env -> trait_clause_id -> unit = + fun _ _ -> () + + method visit_trait_item_name : 'env -> trait_item_name -> unit = + fun _ _ -> () end (** Ancestor for map visitor for [ty] *) @@ -185,6 +209,18 @@ class ['self] map_ty_base = inherit! [_] T.map_const_generic inherit! [_] PV.map_literal_type method visit_type_var_id : 'env -> type_var_id -> type_var_id = fun _ x -> x + + method visit_trait_decl_id : 'env -> trait_decl_id -> trait_decl_id = + fun _ x -> x + + method visit_trait_impl_id : 'env -> trait_impl_id -> trait_impl_id = + fun _ x -> x + + method visit_trait_clause_id : 'env -> trait_clause_id -> trait_clause_id = + fun _ x -> x + + method visit_trait_item_name : 'env -> trait_item_name -> trait_item_name = + fun _ x -> x end (** Ancestor for reduce visitor for [ty] *) @@ -194,6 +230,18 @@ class virtual ['self] reduce_ty_base = inherit! [_] T.reduce_const_generic inherit! [_] PV.reduce_literal_type method visit_type_var_id : 'env -> type_var_id -> 'a = fun _ _ -> self#zero + + method visit_trait_decl_id : 'env -> trait_decl_id -> 'a = + fun _ _ -> self#zero + + method visit_trait_impl_id : 'env -> trait_impl_id -> 'a = + fun _ _ -> self#zero + + method visit_trait_clause_id : 'env -> trait_clause_id -> 'a = + fun _ _ -> self#zero + + method visit_trait_item_name : 'env -> trait_item_name -> 'a = + fun _ _ -> self#zero end (** Ancestor for mapreduce visitor for [ty] *) @@ -205,10 +253,24 @@ class virtual ['self] mapreduce_ty_base = method visit_type_var_id : 'env -> type_var_id -> type_var_id * 'a = fun _ x -> (x, self#zero) + + method visit_trait_decl_id : 'env -> trait_decl_id -> trait_decl_id * 'a = + fun _ x -> (x, self#zero) + + method visit_trait_impl_id : 'env -> trait_impl_id -> trait_impl_id * 'a = + fun _ x -> (x, self#zero) + + method visit_trait_clause_id + : 'env -> trait_clause_id -> trait_clause_id * 'a = + fun _ x -> (x, self#zero) + + method visit_trait_item_name + : 'env -> trait_item_name -> trait_item_name * 'a = + fun _ x -> (x, self#zero) end type ty = - | Adt of type_id * ty list * const_generic list + | Adt of type_id * generic_args (** {!Adt} encodes ADTs and tuples and assumed types. TODO: what about the ended regions? (ADTs may be parameterized @@ -219,8 +281,38 @@ type ty = | TypeVar of type_var_id | Literal of literal_type | Arrow of ty * ty + | TraitType of trait_ref * generic_args * string + (** The string is for the name of the associated type *) + +and trait_ref = { + trait_id : trait_instance_id; + generics : generic_args; + trait_decl_ref : trait_decl_ref; +} + +and trait_decl_ref = { + trait_decl_id : trait_decl_id; + decl_generics : generic_args; (* The name: annoying field collisions... *) +} + +and generic_args = { + types : ty list; + const_generics : const_generic list; + trait_refs : trait_ref list; +} + +and trait_instance_id = + | Self + | TraitImpl of trait_impl_id + | Clause of trait_clause_id + | ParentClause of trait_instance_id * trait_decl_id * trait_clause_id + | ItemClause of + trait_instance_id * trait_decl_id * trait_item_name * trait_clause_id + | TraitRef of trait_ref + | UnknownTrait of string [@@deriving show, + ord, visitors { name = "iter_ty"; @@ -264,12 +356,37 @@ type type_decl_kind = Struct of field list | Enum of variant list | Opaque type type_var = T.type_var [@@deriving show] +type trait_clause = { + clause_id : trait_clause_id; + trait_id : trait_decl_id; + generics : generic_args; +} +[@@deriving show] + +type generic_params = { + types : type_var list; + const_generics : const_generic_var list; + trait_clauses : trait_clause list; +} +[@@deriving show] + +type trait_type_constraint = { + trait_ref : trait_ref; + generics : generic_args; + type_name : trait_item_name; + ty : ty; +} +[@@deriving show, ord] + +type predicates = { trait_type_constraints : trait_type_constraint list } +[@@deriving show] + type type_decl = { def_id : TypeDeclId.id; name : name; - type_params : type_var list; - const_generic_params : const_generic_var list; + generics : generic_params; kind : type_decl_kind; + preds : predicates; } [@@deriving show] @@ -420,8 +537,15 @@ type pure_assumed_fun_id = | FuelEqZero (** Test if some fuel is equal to 0 - TODO: ugly *) [@@deriving show, ord] +type fun_id_or_trait_method_ref = + | FunId of A.fun_id + | TraitMethod of trait_ref * string * fun_decl_id + (** The fun decl id is not really needed and here for convenience purposes *) +[@@deriving show, ord] + (** A function id for a non-assumed function *) -type regular_fun_id = A.fun_id * LoopId.id option * T.RegionGroupId.id option +type regular_fun_id = + fun_id_or_trait_method_ref * LoopId.id option * T.RegionGroupId.id option [@@deriving show, ord] (** A function identifier *) @@ -457,23 +581,20 @@ type projection = { adt_id : type_id; field_id : FieldId.id } [@@deriving show] type qualif_id = | FunOrOp of fun_or_op_id (** A function or an operation *) - | Global of GlobalDeclId.id + | Global of global_decl_id | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) | Proj of projection (** Field projector *) + | TraitConst of trait_ref * generic_args * string + (** A trait associated constant *) [@@deriving show] -(** An instantiated qualified. +(** An instantiated qualifier. Note that for now we have a clear separation between types and expressions, - which explains why we have the [type_params] field: a function or ADT + which explains why we have the [generics] field: a function or ADT constructor is always fully instantiated. *) -type qualif = { - id : qualif_id; - type_args : ty list; - const_generic_args : const_generic list; -} -[@@deriving show] +type qualif = { id : qualif_id; generics : generic_args } [@@deriving show] type field_id = FieldId.id [@@deriving show, ord] type var_id = VarId.id [@@deriving show, ord] @@ -536,6 +657,7 @@ class virtual ['self] mapreduce_expression_base = *) type expression = | Var of var_id (** a variable *) + | CVar of const_generic_var_id (** a const generic var *) | Const of literal | App of texpression * texpression (** Application of a function to an argument. @@ -787,11 +909,11 @@ type fun_sig_info = { - etc. *) type fun_sig = { - type_params : type_var list; - const_generic_params : const_generic_var list; + generics : generic_params; (** TODO: we should analyse the signature to make the type parameters implicit whenever possible *) + preds : predicates; inputs : ty list; - (** The input types. + (** The types of the inputs. Note that those input types take into account the [fuel] parameter, if the function uses fuel for termination, and the [state] parameter, @@ -861,8 +983,11 @@ type fun_body = { } [@@deriving show] +type fun_kind = A.fun_kind [@@deriving show] + type fun_decl = { def_id : FunDeclId.id; + kind : fun_kind; num_loops : int; (** The number of loops in the parent forward function (basically the number of loops appearing in the original Rust functions, unless some loops are @@ -882,3 +1007,30 @@ type fun_decl = { body : fun_body option; } [@@deriving show] + +type trait_decl = { + def_id : trait_decl_id; + name : name; + generics : generic_params; + preds : predicates; + parent_clauses : trait_clause list; + consts : (trait_item_name * (ty * global_decl_id option)) list; + types : (trait_item_name * (trait_clause list * ty option)) list; + required_methods : (trait_item_name * fun_decl_id) list; + provided_methods : (trait_item_name * fun_decl_id option) list; +} +[@@deriving show] + +type trait_impl = { + def_id : trait_impl_id; + name : name; + impl_trait : trait_decl_ref; + generics : generic_params; + preds : predicates; + parent_trait_refs : trait_ref list; + consts : (trait_item_name * (ty * global_decl_id)) list; + types : (trait_item_name * (trait_ref list * ty)) list; + required_methods : (trait_item_name * fun_decl_id) list; + provided_methods : (trait_item_name * fun_decl_id) list; +} +[@@deriving show] diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index b6025df4..f3e6cbe2 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -376,8 +376,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = let ty = e.ty in let ctx, e = match e.e with - | Var _ -> (* Nothing to do *) (ctx, e.e) - | Const _ -> (* Nothing to do *) (ctx, e.e) + | Var _ | CVar _ | Const _ -> (* Nothing to do *) (ctx, e.e) | App (app, arg) -> let ctx, app = update_texpression app ctx in let ctx, arg = update_texpression arg ctx in @@ -584,13 +583,10 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = | Qualif { id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; - type_args = _; - const_generic_args = _; + generics = _; } -> (* Lookup the def *) - let decl = - TypeDeclId.Map.find adt_id ctx.type_context.type_decls - in + let decl = TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in (* Check that there are as many arguments as there are fields - note that the def should have a body (otherwise we couldn't use the constructor) *) @@ -599,8 +595,7 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = (* Check if the definition is recursive *) let is_rec = match - TypeDeclId.Map.find adt_id - ctx.type_context.type_decls_groups + TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls_groups with | NonRec _ -> false | Rec _ -> true @@ -682,8 +677,8 @@ let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) | _ -> false in (* And either: - * 2.1 the right-expression is a variable or a global *) - let var_or_global = is_var re || is_global re in + * 2.1 the right-expression is a variable, a global or a const generic var *) + let var_or_global = is_var re || is_cvar re || is_global re in (* Or: * 2.2 the right-expression is a constant value, an ADT value, * a projection or a primitive function call *and* the flag @@ -767,10 +762,10 @@ let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) In this situation, we can remove the call [f@fwd x]. *) let expression_contains_child_call_in_all_paths (ctx : trans_ctx) - (id0 : A.fun_id) (lp_id0 : LoopId.id option) - (rg_id0 : T.RegionGroupId.id option) (tys0 : ty list) + (id0 : fun_id_or_trait_method_ref) (lp_id0 : LoopId.id option) + (rg_id0 : T.RegionGroupId.id option) (generics0 : generic_args) (args0 : texpression list) (e : texpression) : bool = - let check_call (fun_id1 : fun_or_op_id) (tys1 : ty list) + let check_call (fun_id1 : fun_or_op_id) (generics1 : generic_args) (args1 : texpression list) : bool = (* Check the fun_ids, to see if call1's function is a child of call0's function *) match fun_id1 with @@ -793,7 +788,12 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) (* We need to use the regions hierarchy *) (* First, lookup the signature of the LLBC function *) let sg = - LlbcAstUtils.lookup_fun_sig id0 ctx.fun_context.fun_decls + let id0 = + match id0 with + | FunId fun_id -> fun_id + | TraitMethod (_, _, fun_decl_id) -> Regular fun_decl_id + in + LlbcAstUtils.lookup_fun_sig id0 ctx.fun_ctx.fun_decls in (* Compute the set of ancestors of the function in call1 *) let call1_ancestors = @@ -817,8 +817,8 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) let input_eq (v0, v1) = PureUtils.remove_meta v0 = PureUtils.remove_meta v1 in - (* Compare the input types and the prefix of the input arguments *) - tys0 = tys1 && List.for_all input_eq args + (* Compare the generics and the prefix of the input arguments *) + generics0 = generics1 && List.for_all input_eq args else (* Not a child *) false else (* Not the same function *) @@ -834,7 +834,7 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) method! visit_texpression env e = match e.e with - | Var _ | Const _ -> fun _ -> false + | Var _ | CVar _ | Const _ -> fun _ -> false | StructUpdate _ -> (* There shouldn't be monadic calls in structure updates - also note that by returning [false] we are conservative: we might @@ -844,8 +844,8 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) | Let (_, _, re, e) -> ( match opt_destruct_function_call re with | None -> fun () -> self#visit_texpression env e () - | Some (func1, tys1, args1) -> - let call_is_child = check_call func1 tys1 args1 in + | Some (func1, generics1, args1) -> + let call_is_child = check_call func1 generics1 args1 in if call_is_child then fun () -> true else fun () -> self#visit_texpression env e ()) | App _ -> ( @@ -930,7 +930,7 @@ let filter_useless (filter_monadic_calls : bool) (ctx : trans_ctx) method! visit_expression env e = match e with - | Var _ | Const _ | App _ | Qualif _ + | Var _ | CVar _ | Const _ | App _ | Qualif _ | Switch (_, _) | Meta (_, _) | StructUpdate _ | Abs _ -> @@ -1086,13 +1086,12 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = | Qualif { id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; - type_args; - const_generic_args; + generics; } -> (* This is a struct *) (* Retrieve the definiton, to find how many fields there are *) let adt_decl = - TypeDeclId.Map.find adt_id ctx.type_context.type_decls + TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in let fields = match adt_decl.kind with @@ -1108,7 +1107,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = * [x.field] for some variable [x], and where the projection * is for the proper ADT *) let to_var_proj (i : int) (arg : texpression) : - (ty list * const_generic list * var_id) option = + (generic_args * var_id) option = match arg.e with | App (proj, x) -> ( match (proj.e, x.e) with @@ -1116,16 +1115,14 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = { id = Proj { adt_id = AdtId proj_adt_id; field_id }; - type_args = proj_type_args; - const_generic_args = proj_const_generic_args; + generics = proj_generics; }, Var v ) -> (* We check that this is the proper ADT, and the proper field *) if proj_adt_id = adt_id && FieldId.to_int field_id = i - then - Some (proj_type_args, proj_const_generic_args, v) + then Some (proj_generics, v) else None | _ -> None) | _ -> None @@ -1136,14 +1133,13 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = if List.length args = num_fields then (* Check that this is the same variable we project from - * note that we checked above that there is at least one field *) - let (_, _, x), end_args = Collections.List.pop args in - if List.for_all (fun (_, _, y) -> y = x) end_args then ( + let (_, x), end_args = Collections.List.pop args in + if List.for_all (fun (_, y) -> y = x) end_args then ( (* We can substitute *) (* Sanity check: all types correct *) assert ( List.for_all - (fun (tys, cgs, _) -> - tys = type_args && cgs = const_generic_args) + (fun (generics1, _) -> generics1 = generics) args); { e with e = Var x }) else super#visit_texpression env e @@ -1162,8 +1158,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = | ( Qualif { id = Proj { adt_id = AdtId proj_adt_id; field_id }; - type_args = _; - const_generic_args = _; + generics = _; }, Var v ) -> (* We check that this is the proper ADT, and the proper field *) @@ -1361,8 +1356,8 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = let loop_sig = { - type_params = fun_sig.type_params; - const_generic_params = fun_sig.const_generic_params; + generics = fun_sig.generics; + preds = fun_sig.preds; inputs = inputs_tys; output; doutputs; @@ -1427,6 +1422,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = let loop_def = { def_id = def.def_id; + kind = def.kind; num_loops; loop_id = Some loop.loop_id; back_id = def.back_id; @@ -1466,13 +1462,12 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = In such situation, we can remove the forward function definition altogether. *) -let keep_forward (trans : pure_fun_translation) : bool = - let (fwd, _), backs = trans in +let keep_forward (fwd : fun_and_loops) (backs : fun_and_loops list) : bool = (* Note that at this point, the output types are no longer seen as tuples: * they should be lists of length 1. *) if !Config.filter_useless_functions - && fwd.signature.output = mk_result_ty mk_unit_ty + && fwd.f.signature.output = mk_result_ty mk_unit_ty && backs <> [] then false else true @@ -1518,7 +1513,7 @@ let unit_vars_to_unit (def : fun_decl) : fun_decl = function calls, and when translating end abstractions. Here, we can do something simpler, in one micro-pass. *) -let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = +let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = (* The map visitor *) let obj = object @@ -1527,30 +1522,44 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = method! visit_texpression env e = match opt_destruct_function_call e with | Some (fun_id, _tys, args) -> ( + (* Below, when dealing with the arguments: we consider the very + * general case, where functions could be boxed (meaning we + * could have: [box_new f x]) + * *) match fun_id with - | Fun (FromLlbc (A.Assumed aid, _lp_id, rg_id)) -> ( - (* Below, when dealing with the arguments: we consider the very - * general case, where functions could be boxed (meaning we - * could have: [box_new f x]) - * *) + | Fun (FromLlbc (FunId (Assumed aid), _lp_id, rg_id)) -> ( match (aid, rg_id) with - | A.BoxNew, _ -> + | BoxNew, _ -> assert (rg_id = None); let arg, args = Collections.List.pop args in mk_apps arg args - | A.BoxDeref, None -> + | BoxFree, _ -> + assert (args = []); + mk_unit_rvalue + | ( ( SliceIndexShared | SliceIndexMut | ArrayIndexShared + | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut + | ArrayRepeat | SliceLen ), + _ ) -> + super#visit_texpression env e) + | Fun (FromLlbc (FunId (Regular fid), _lp_id, rg_id)) -> ( + (* Lookup the function name *) + let def = FunDeclId.Map.find fid ctx.fun_ctx.fun_decls in + match + (Names.name_no_disambiguators_to_string def.name, rg_id) + with + | "alloc::boxed::Box::deref", None -> (* [Box::deref] forward is the identity *) let arg, args = Collections.List.pop args in mk_apps arg args - | A.BoxDeref, Some _ -> + | "alloc::boxed::Box::deref", Some _ -> (* [Box::deref] backward is [()] (doesn't give back anything) *) assert (args = []); mk_unit_rvalue - | A.BoxDerefMut, None -> + | "alloc::boxed::Box::deref_mut", None -> (* [Box::deref_mut] forward is the identity *) let arg, args = Collections.List.pop args in mk_apps arg args - | A.BoxDerefMut, Some _ -> + | "alloc::boxed::Box::deref_mut", Some _ -> (* [Box::deref_mut] back is almost the identity: * let box_deref_mut (x_init : t) (x_back : t) : t = x_back * *) @@ -1560,17 +1569,7 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = | _ -> raise (Failure "Unreachable") in mk_apps arg args - | A.BoxFree, _ -> - assert (args = []); - mk_unit_rvalue - | ( ( A.Replace | VecNew | VecPush | VecInsert | VecLen - | VecIndex | VecIndexMut | ArraySubsliceShared - | ArraySubsliceMut | SliceIndexShared | SliceIndexMut - | SliceSubsliceShared | SliceSubsliceMut | ArrayIndexShared - | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut - | SliceLen ), - _ ) -> - super#visit_texpression env e) + | _ -> super#visit_texpression env e) | _ -> super#visit_texpression env e) | _ -> super#visit_texpression env e end @@ -1914,7 +1913,7 @@ let apply_end_passes_to_def (ctx : trans_ctx) (def : fun_decl) : fun_decl = [ctx]: used only for printing. *) let apply_passes_to_def (ctx : trans_ctx) (def : fun_decl) : - (fun_decl * fun_decl list) option = + fun_and_loops option = (* Debug *) log#ldebug (lazy @@ -1955,9 +1954,9 @@ let apply_passes_to_def (ctx : trans_ctx) (def : fun_decl) : let def, loops = decompose_loops def in (* Apply the remaining passes *) - let def = apply_end_passes_to_def ctx def in + let f = apply_end_passes_to_def ctx def in let loops = List.map (apply_end_passes_to_def ctx) loops in - Some (def, loops) + Some { f; loops } (** Small utility for {!filter_loop_inputs} *) let filter_prefix (keep : bool list) (ls : 'a list) : 'a list = @@ -1983,8 +1982,8 @@ end module FunLoopIdMap = Collections.MakeMap (FunLoopIdOrderedType) (** Filter the useless loop input parameters. *) -let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : - (bool * pure_fun_translation) list = +let filter_loop_inputs (transl : pure_fun_translation list) : + pure_fun_translation list = (* We need to explore groups of mutually recursive functions. In order to compute which parameters are useless, we need to explore the functions by groups of mutually recursive definitions. @@ -2002,10 +2001,11 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : (List.concat (List.concat (List.map - (fun (_, ((fwd, loops_fwd), backs)) -> - [ fwd :: loops_fwd ] + (fun { fwd; backs; _ } -> + [ fwd.f :: fwd.loops ] :: List.map - (fun (back, loops_back) -> [ back :: loops_back ]) + (fun { f = back; loops = loops_back } -> + [ back :: loops_back ]) backs) transl))) in @@ -2030,7 +2030,6 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : additional parameters. *) let used_map = ref FunLoopIdMap.empty in - let fun_id_to_fun_loop_id (fid, loop_id, _) = (fid, loop_id) in (* We start by computing the filtering information, for each function *) let compute_one_filter_info (decl : fun_decl) = @@ -2051,7 +2050,7 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : let inputs_set = VarId.Set.of_list (List.map var_get_id inputs_prefix) in assert (Option.is_some decl.loop_id); - let fun_id = (A.Regular decl.def_id, decl.loop_id) in + let fun_id = (E.Regular decl.def_id, decl.loop_id) in let set_used vid = used := List.map (fun (vid', b) -> (vid', b || vid = vid')) !used @@ -2075,8 +2074,8 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : match e_app.e with | Qualif qualif -> ( match qualif.id with - | FunOrOp (Fun (FromLlbc fun_id')) -> - if fun_id_to_fun_loop_id fun_id' = fun_id then ( + | FunOrOp (Fun (FromLlbc (FunId fun_id', loop_id', _))) -> + if (fun_id', loop_id') = fun_id then ( (* For each argument, check if it is exactly the original input parameter. Note that there shouldn't be partial applications of loop functions: the number of arguments @@ -2135,22 +2134,15 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : (* We then apply the filtering to all the function definitions at once *) let filter_in_one (decl : fun_decl) : fun_decl = (* Filter the function signature *) - let fun_id = (A.Regular decl.def_id, decl.loop_id, decl.back_id) in + let fun_id = (E.Regular decl.def_id, decl.loop_id) in let decl = - match FunLoopIdMap.find_opt (fun_id_to_fun_loop_id fun_id) !used_map with + match FunLoopIdMap.find_opt fun_id !used_map with | None -> (* Nothing to filter *) decl | Some used_info -> let num_filtered = List.length (List.filter (fun b -> not b) used_info) in - let { - type_params; - const_generic_params; - inputs; - output; - doutputs; - info; - } = + let { generics; preds; inputs; output; doutputs; info } = decl.signature in let { @@ -2178,16 +2170,7 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : effect_info; } in - let signature = - { - type_params; - const_generic_params; - inputs; - output; - doutputs; - info; - } - in + let signature = { generics; preds; inputs; output; doutputs; info } in { decl with signature } in @@ -2201,9 +2184,7 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : let { inputs; inputs_lvs; body } = body in let inputs, inputs_lvs = - match - FunLoopIdMap.find_opt (fun_id_to_fun_loop_id fun_id) !used_map - with + match FunLoopIdMap.find_opt fun_id !used_map with | None -> (* Nothing to filter *) (inputs, inputs_lvs) | Some used_info -> let inputs = filter_prefix used_info inputs in @@ -2223,11 +2204,10 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : match e_app.e with | Qualif qualif -> ( match qualif.id with - | FunOrOp (Fun (FromLlbc fun_id)) -> ( + | FunOrOp (Fun (FromLlbc (FunId fun_id, loop_id, _))) + -> ( match - FunLoopIdMap.find_opt - (fun_id_to_fun_loop_id fun_id) - !used_map + FunLoopIdMap.find_opt (fun_id, loop_id) !used_map with | None -> super#visit_texpression env e | Some used_info -> @@ -2267,13 +2247,13 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : in let transl = List.map - (fun (b, (fwd, backs)) -> - let filter_fun_and_loops (f, fl) = - (filter_in_one f, List.map filter_in_one fl) + (fun trans -> + let filter_fun_and_loops f = + { f = filter_in_one f.f; loops = List.map filter_in_one f.loops } in - let fwd = filter_fun_and_loops fwd in - let backs = List.map filter_fun_and_loops backs in - (b, (fwd, backs))) + let fwd = filter_fun_and_loops trans.fwd in + let backs = List.map filter_fun_and_loops trans.backs in + { trans with fwd; backs }) transl in @@ -2294,18 +2274,17 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : but convenient. *) let apply_passes_to_pure_fun_translations (ctx : trans_ctx) - (transl : (fun_decl * fun_decl list) list) : - (bool * pure_fun_translation) list = - let apply_to_one (trans : fun_decl * fun_decl list) : - bool * pure_fun_translation = + (transl : (fun_decl * fun_decl list) list) : pure_fun_translation list = + let apply_to_one (trans : fun_decl * fun_decl list) : pure_fun_translation = (* Apply the passes to the individual functions *) - let forward, backwards = trans in - let forward = Option.get (apply_passes_to_def ctx forward) in - let backwards = List.filter_map (apply_passes_to_def ctx) backwards in - let trans = (forward, backwards) in + let fwd, backs = trans in + let fwd = Option.get (apply_passes_to_def ctx fwd) in + let backs = List.filter_map (apply_passes_to_def ctx) backs in (* Compute whether we need to filter the forward function or not *) - (keep_forward trans, trans) + let keep_fwd = keep_forward fwd backs in + { keep_fwd; fwd; backs } in + let transl = List.map apply_to_one transl in (* Filter the useless inputs in the loop functions *) diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 8d28bb8a..2ad942bb 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -9,17 +9,19 @@ open PureUtils of fields is fixed: it shouldn't be used for arrays, slices, etc. *) let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) - (type_id : type_id) (variant_id : VariantId.id option) (tys : ty list) - (cgs : const_generic list) : ty list = + (type_id : type_id) (variant_id : VariantId.id option) + (generics : generic_args) : ty list = match type_id with | Tuple -> (* Tuple *) + assert (generics.const_generics = []); + assert (generics.trait_refs = []); assert (variant_id = None); - tys + generics.types | AdtId def_id -> (* "Regular" ADT *) let def = TypeDeclId.Map.find def_id type_decls in - type_decl_get_instantiated_fields_types def variant_id tys cgs + type_decl_get_instantiated_fields_types def variant_id generics | Assumed aty -> ( (* Assumed type *) match aty with @@ -27,14 +29,14 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) (* This type is opaque *) raise (Failure "Unreachable: opaque type") | Result -> - let ty = Collections.List.to_cons_nil tys in + let ty = Collections.List.to_cons_nil generics.types in let variant_id = Option.get variant_id in if variant_id = result_return_id then [ ty ] else if variant_id = result_fail_id then [ mk_error_ty ] else raise (Failure "Unreachable: improper variant id for result type") | Error -> - assert (tys = []); + assert (generics = empty_generic_args); let variant_id = Option.get variant_id in assert ( variant_id = error_failure_id || variant_id = error_out_of_fuel_id); @@ -44,18 +46,7 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) if variant_id = fuel_zero_id then [] else if variant_id = fuel_succ_id then [ mk_fuel_ty ] else raise (Failure "Unreachable: improper variant id for fuel type") - | Option -> - let ty = Collections.List.to_cons_nil tys in - let variant_id = Option.get variant_id in - if variant_id = option_some_id then [ ty ] - else if variant_id = option_none_id then [] - else - raise (Failure "Unreachable: improper variant id for option type") - | Range -> - let ty = Collections.List.to_cons_nil tys in - assert (variant_id = None); - [ ty; ty ] - | Vec | Array | Slice | Str -> + | Array | Slice | Str | RawPtr _ -> (* Array: when not symbolic values (for instance, because of aggregates), the array expressions are introduced as struct updates *) raise (Failure "Attempting to access the fields of an opaque type")) @@ -65,6 +56,9 @@ type tc_ctx = { global_decls : A.global_decl A.GlobalDeclId.Map.t; (** The global declarations *) env : ty VarId.Map.t; (** Environment from variables to types *) + const_generics : ty T.ConstGenericVarId.Map.t; + (** The types of the const generics *) + (* TODO: add trait type constraints *) } let check_literal (v : literal) (ty : literal_type) : unit = @@ -86,12 +80,13 @@ let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = { ctx with env } | PatAdt av -> (* Compute the field types *) - let type_id, tys, cgs = ty_as_adt v.ty in + let type_id, generics = ty_as_adt v.ty in let field_tys = - get_adt_field_types ctx.type_decls type_id av.variant_id tys cgs + get_adt_field_types ctx.type_decls type_id av.variant_id generics in let check_value (ctx : tc_ctx) (ty : ty) (v : typed_pattern) : tc_ctx = if ty <> v.ty then ( + (* TODO: we need to normalize the types *) log#serror ("check_typed_pattern: not the same types:" ^ "\n- ty: " ^ show_ty ty ^ "\n- v.ty: " ^ show_ty v.ty); @@ -115,6 +110,9 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = match VarId.Map.find_opt var_id ctx.env with | None -> () | Some ty -> assert (ty = e.ty)) + | CVar cg_id -> + let ty = T.ConstGenericVarId.Map.find cg_id ctx.const_generics in + assert (ty = e.ty) | Const cv -> check_literal cv (ty_as_literal e.ty) | App (app, arg) -> let input_ty, output_ty = destruct_arrow app.ty in @@ -133,35 +131,34 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = match qualif.id with | FunOrOp _ -> () (* TODO *) | Global _ -> () (* TODO *) + | TraitConst _ -> () (* TODO *) | Proj { adt_id = proj_adt_id; field_id } -> (* Note we can only project fields of structures (not enumerations) *) (* Deconstruct the projector type *) let adt_ty, field_ty = destruct_arrow e.ty in - let adt_id, adt_type_args, adt_cg_args = ty_as_adt adt_ty in + let adt_id, adt_generics = ty_as_adt adt_ty in (* Check the ADT type *) assert (adt_id = proj_adt_id); - assert (adt_type_args = qualif.type_args); - assert (adt_cg_args = qualif.const_generic_args); + assert (adt_generics = qualif.generics); (* Retrieve and check the expected field type *) let variant_id = None in let expected_field_tys = get_adt_field_types ctx.type_decls proj_adt_id variant_id - qualif.type_args qualif.const_generic_args + qualif.generics in let expected_field_ty = FieldId.nth expected_field_tys field_id in assert (expected_field_ty = field_ty) | AdtCons id -> ( let expected_field_tys = get_adt_field_types ctx.type_decls id.adt_id id.variant_id - qualif.type_args qualif.const_generic_args + qualif.generics in let field_tys, adt_ty = destruct_arrows e.ty in assert (expected_field_tys = field_tys); match adt_ty with - | Adt (type_id, tys, cgs) -> + | Adt (type_id, generics) -> assert (type_id = id.adt_id); - assert (tys = qualif.type_args); - assert (cgs = qualif.const_generic_args) + assert (generics = qualif.generics) | _ -> raise (Failure "Unreachable"))) | Let (monadic, pat, re, e_next) -> let expected_pat_ty = if monadic then destruct_result re.ty else re.ty in @@ -207,15 +204,14 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = | Some ty -> assert (ty = e.ty)); (* Check the fields *) (* Retrieve and check the expected field type *) - let adt_id, adt_type_args, adt_cg_args = ty_as_adt e.ty in + let adt_id, adt_generics = ty_as_adt e.ty in assert (adt_id = supd.struct_id); (* The id can only be: a custom type decl or an array *) match adt_id with | AdtId _ -> let variant_id = None in let expected_field_tys = - get_adt_field_types ctx.type_decls adt_id variant_id adt_type_args - adt_cg_args + get_adt_field_types ctx.type_decls adt_id variant_id adt_generics in List.iter (fun (fid, fe) -> @@ -224,7 +220,9 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = check_texpression ctx fe) supd.updates | Assumed Array -> - let expected_field_ty = Collections.List.to_cons_nil adt_type_args in + let expected_field_ty = + Collections.List.to_cons_nil adt_generics.types + in List.iter (fun (_, fe) -> assert (expected_field_ty = fe.ty); diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 1c8d8921..3aeabffe 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -89,14 +89,31 @@ let mk_mplace (var_id : E.VarId.id) (name : string option) (projection : mprojection) : mplace = { var_id; name; projection } +let empty_generic_params : generic_params = + { types = []; const_generics = []; trait_clauses = [] } + +let empty_generic_args : generic_args = + { types = []; const_generics = []; trait_refs = [] } + +let mk_generic_args_from_types (types : ty list) : generic_args = + { types; const_generics = []; trait_refs = [] } + +type subst = { + ty_subst : TypeVarId.id -> ty; + cg_subst : ConstGenericVarId.id -> const_generic; + tr_subst : TraitClauseId.id -> trait_instance_id; + tr_self : trait_instance_id; +} + (** Type substitution *) -let ty_substitute (tsubst : TypeVarId.id -> ty) - (cgsubst : ConstGenericVarId.id -> const_generic) (ty : ty) : ty = +let ty_substitute (subst : subst) (ty : ty) : ty = let obj = object inherit [_] map_ty - method! visit_TypeVar _ var_id = tsubst var_id - method! visit_ConstGenericVar _ var_id = cgsubst var_id + method! visit_TypeVar _ var_id = subst.ty_subst var_id + method! visit_ConstGenericVar _ var_id = subst.cg_subst var_id + method! visit_Clause _ id = subst.tr_subst id + method! visit_Self _ = subst.tr_self end in obj#visit_ty () ty @@ -115,6 +132,18 @@ let make_const_generic_subst (vars : const_generic_var list) (cgs : const_generic list) : ConstGenericVarId.id -> const_generic = Substitute.make_const_generic_subst_from_vars vars cgs +let make_trait_subst (clauses : trait_clause list) (refs : trait_ref list) : + TraitClauseId.id -> trait_instance_id = + let clauses = List.map (fun x -> x.clause_id) clauses in + let refs = List.map (fun x -> TraitRef x) refs in + let ls = List.combine clauses refs in + let mp = + List.fold_left + (fun mp (k, v) -> TraitClauseId.Map.add k v mp) + TraitClauseId.Map.empty ls + in + fun id -> TraitClauseId.Map.find id mp + (** Retrieve the list of fields for the given variant of a {!type:Aeneas.Pure.type_decl}. Raises [Invalid_argument] if the arguments are incorrect. @@ -135,20 +164,27 @@ let type_decl_get_fields (def : type_decl) - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " ^ opt_variant_id)) +let make_subst_from_generics (params : generic_params) (args : generic_args) + (tr_self : trait_instance_id) : subst = + let ty_subst = make_type_subst params.types args.types in + let cg_subst = + make_const_generic_subst params.const_generics args.const_generics + in + let tr_subst = make_trait_subst params.trait_clauses args.trait_refs in + { ty_subst; cg_subst; tr_subst; tr_self } + (** Instantiate the type variables for the chosen variant in an ADT definition, and return the list of the types of its fields *) let type_decl_get_instantiated_fields_types (def : type_decl) - (opt_variant_id : VariantId.id option) (types : ty list) - (cgs : const_generic list) : ty list = - let ty_subst = make_type_subst def.type_params types in - let cg_subst = make_const_generic_subst def.const_generic_params cgs in + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = + (* There shouldn't be any reference to Self *) + let tr_self = UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.generics generics tr_self in let fields = type_decl_get_fields def opt_variant_id in - List.map (fun f -> ty_substitute ty_subst cg_subst f.field_ty) fields + List.map (fun f -> ty_substitute subst f.field_ty) fields -let fun_sig_substitute (tsubst : TypeVarId.id -> ty) - (cgsubst : ConstGenericVarId.id -> const_generic) (sg : fun_sig) : - inst_fun_sig = - let subst = ty_substitute tsubst cgsubst in +let fun_sig_substitute (subst : subst) (sg : fun_sig) : inst_fun_sig = + let subst = ty_substitute subst in let inputs = List.map subst sg.inputs in let output = subst sg.output in let doutputs = List.map subst sg.doutputs in @@ -164,7 +200,8 @@ let fun_sig_substitute (tsubst : TypeVarId.id -> ty) *) let rec let_group_requires_parentheses (e : texpression) : bool = match e.e with - | Var _ | Const _ | App _ | Abs _ | Qualif _ | StructUpdate _ -> false + | Var _ | CVar _ | Const _ | App _ | Abs _ | Qualif _ | StructUpdate _ -> + false | Let (monadic, _, _, next_e) -> if monadic then true else let_group_requires_parentheses next_e | Switch (_, _) -> false @@ -184,15 +221,18 @@ let is_var (e : texpression) : bool = let as_var (e : texpression) : VarId.id = match e.e with Var v -> v | _ -> raise (Failure "Unreachable") +let is_cvar (e : texpression) : bool = + match e.e with CVar _ -> true | _ -> false + let is_global (e : texpression) : bool = match e.e with Qualif { id = Global _; _ } -> true | _ -> false let is_const (e : texpression) : bool = match e.e with Const _ -> true | _ -> false -let ty_as_adt (ty : ty) : type_id * ty list * const_generic list = +let ty_as_adt (ty : ty) : type_id * generic_args = match ty with - | Adt (id, tys, cgs) -> (id, tys, cgs) + | Adt (id, generics) -> (id, generics) | _ -> raise (Failure "Unreachable") (** Remove the external occurrences of {!Meta} *) @@ -290,28 +330,30 @@ let destruct_qualif_app (e : texpression) : qualif * texpression list = (** Destruct an expression into a function call, if possible *) let opt_destruct_function_call (e : texpression) : - (fun_or_op_id * ty list * texpression list) option = + (fun_or_op_id * generic_args * texpression list) option = match opt_destruct_qualif_app e with | None -> None | Some (qualif, args) -> ( match qualif.id with - | FunOrOp fun_id -> Some (fun_id, qualif.type_args, args) + | FunOrOp fun_id -> Some (fun_id, qualif.generics, args) | _ -> None) let opt_destruct_result (ty : ty) : ty option = match ty with - | Adt (Assumed Result, tys, cgs) -> - assert (cgs = []); - Some (Collections.List.to_cons_nil tys) + | Adt (Assumed Result, generics) -> + assert (generics.const_generics = []); + assert (generics.trait_refs = []); + Some (Collections.List.to_cons_nil generics.types) | _ -> None let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) let opt_destruct_tuple (ty : ty) : ty list option = match ty with - | Adt (Tuple, tys, cgs) -> - assert (cgs = []); - Some tys + | Adt (Tuple, generics) -> + assert (generics.const_generics = []); + assert (generics.trait_refs = []); + Some generics.types | _ -> None let mk_abs (x : typed_pattern) (e : texpression) : texpression = @@ -383,14 +425,16 @@ let mk_switch (scrut : texpression) (sb : switch_body) : texpression = - if there is > one type: wrap them in a tuple *) let mk_simpl_tuple_ty (tys : ty list) : ty = - match tys with [ ty ] -> ty | _ -> Adt (Tuple, tys, []) + match tys with + | [ ty ] -> ty + | _ -> Adt (Tuple, mk_generic_args_from_types tys) let mk_bool_ty : ty = Literal Bool -let mk_unit_ty : ty = Adt (Tuple, [], []) +let mk_unit_ty : ty = Adt (Tuple, empty_generic_args) let mk_unit_rvalue : texpression = let id = AdtCons { adt_id = Tuple; variant_id = None } in - let qualif = { id; type_args = []; const_generic_args = [] } in + let qualif = { id; generics = empty_generic_args } in let e = Qualif qualif in let ty = mk_unit_ty in { e; ty } @@ -430,7 +474,7 @@ let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = | [ v ] -> v | _ -> let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in - let ty = Adt (Tuple, tys, []) in + let ty = Adt (Tuple, mk_generic_args_from_types tys) in let value = PatAdt { variant_id = None; field_values = vl } in { value; ty } @@ -441,11 +485,11 @@ let mk_simpl_tuple_texpression (vl : texpression list) : texpression = | _ -> (* Compute the types of the fields, and the type of the tuple constructor *) let tys = List.map (fun (v : texpression) -> v.ty) vl in - let ty = Adt (Tuple, tys, []) in + let ty = Adt (Tuple, mk_generic_args_from_types tys) in let ty = mk_arrows tys ty in (* Construct the tuple constructor qualifier *) let id = AdtCons { adt_id = Tuple; variant_id = None } in - let qualif = { id; type_args = tys; const_generic_args = [] } in + let qualif = { id; generics = mk_generic_args_from_types tys } in (* Put everything together *) let cons = { e = Qualif qualif; ty } in mk_apps cons vl @@ -463,32 +507,36 @@ let ty_as_integer (t : ty) : T.integer_type = let ty_as_literal (t : ty) : T.literal_type = match t with Literal ty -> ty | _ -> raise (Failure "Unreachable") -let mk_state_ty : ty = Adt (Assumed State, [], []) -let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ], []) -let mk_error_ty : ty = Adt (Assumed Error, [], []) -let mk_fuel_ty : ty = Adt (Assumed Fuel, [], []) +let mk_state_ty : ty = Adt (Assumed State, empty_generic_args) + +let mk_result_ty (ty : ty) : ty = + Adt (Assumed Result, mk_generic_args_from_types [ ty ]) + +let mk_error_ty : ty = Adt (Assumed Error, empty_generic_args) +let mk_fuel_ty : ty = Adt (Assumed Fuel, empty_generic_args) let mk_error (error : VariantId.id) : texpression = let ty = mk_error_ty in let id = AdtCons { adt_id = Assumed Error; variant_id = Some error } in - let qualif = { id; type_args = []; const_generic_args = [] } in + let qualif = { id; generics = empty_generic_args } in let e = Qualif qualif in { e; ty } let unwrap_result_ty (ty : ty) : ty = match ty with - | Adt (Assumed Result, [ ty ], cgs) -> - assert (cgs = []); + | Adt + (Assumed Result, { types = [ ty ]; const_generics = []; trait_refs = [] }) + -> ty | _ -> raise (Failure "not a result type") let mk_result_fail_texpression (error : texpression) (ty : ty) : texpression = let type_args = [ ty ] in - let ty = Adt (Assumed Result, type_args, []) in + let ty = Adt (Assumed Result, mk_generic_args_from_types type_args) in let id = AdtCons { adt_id = Assumed Result; variant_id = Some result_fail_id } in - let qualif = { id; type_args; const_generic_args = [] } in + let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in let cons_ty = mk_arrow error.ty ty in let cons = { e = cons_e; ty = cons_ty } in @@ -501,11 +549,11 @@ let mk_result_fail_texpression_with_error_id (error : VariantId.id) (ty : ty) : let mk_result_return_texpression (v : texpression) : texpression = let type_args = [ v.ty ] in - let ty = Adt (Assumed Result, type_args, []) in + let ty = Adt (Assumed Result, mk_generic_args_from_types type_args) in let id = AdtCons { adt_id = Assumed Result; variant_id = Some result_return_id } in - let qualif = { id; type_args; const_generic_args = [] } in + let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in let cons_ty = mk_arrow v.ty ty in let cons = { e = cons_e; ty = cons_ty } in @@ -514,7 +562,7 @@ let mk_result_return_texpression (v : texpression) : texpression = (** Create a [Fail err] pattern which captures the error *) let mk_result_fail_pattern (error_pat : pattern) (ty : ty) : typed_pattern = let error_pat : typed_pattern = { value = error_pat; ty = mk_error_ty } in - let ty = Adt (Assumed Result, [ ty ], []) in + let ty = Adt (Assumed Result, mk_generic_args_from_types [ ty ]) in let value = PatAdt { variant_id = Some result_fail_id; field_values = [ error_pat ] } in @@ -526,7 +574,7 @@ let mk_result_fail_pattern_ignore_error (ty : ty) : typed_pattern = mk_result_fail_pattern error_pat ty let mk_result_return_pattern (v : typed_pattern) : typed_pattern = - let ty = Adt (Assumed Result, [ v.ty ], []) in + let ty = Adt (Assumed Result, mk_generic_args_from_types [ v.ty ]) in let value = PatAdt { variant_id = Some result_return_id; field_values = [ v ] } in @@ -561,11 +609,11 @@ let rec typed_pattern_to_texpression (pat : typed_pattern) : texpression option let fields_values = List.map (fun e -> Option.get e) fields in (* Retrieve the type id and the type args from the pat type (simpler this way *) - let adt_id, type_args, const_generic_args = ty_as_adt pat.ty in + let adt_id, generics = ty_as_adt pat.ty in (* Create the constructor *) let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in - let qualif = { id = qualif_id; type_args; const_generic_args } in + let qualif = { id = qualif_id; generics } in let cons_e = Qualif qualif in let field_tys = List.map (fun (v : texpression) -> v.ty) fields_values @@ -577,3 +625,55 @@ let rec typed_pattern_to_texpression (pat : typed_pattern) : texpression option Some (mk_apps cons fields_values).e in match e_opt with None -> None | Some e -> Some { e; ty = pat.ty } + +type trait_decl_method_decl_id = { is_provided : bool; id : fun_decl_id } + +let trait_decl_get_method (trait_decl : trait_decl) (method_name : string) : + trait_decl_method_decl_id = + (* First look in the required methods *) + let method_id = + List.find_opt (fun (s, _) -> s = method_name) trait_decl.required_methods + in + match method_id with + | Some (_, id) -> { is_provided = false; id } + | None -> + (* Must be a provided method *) + let _, id = + List.find (fun (s, _) -> s = method_name) trait_decl.provided_methods + in + { is_provided = true; id = Option.get id } + +let trait_decl_is_empty (trait_decl : trait_decl) : bool = + let { + def_id = _; + name = _; + generics = _; + preds = _; + parent_clauses; + consts; + types; + required_methods; + provided_methods; + } = + trait_decl + in + parent_clauses = [] && consts = [] && types = [] && required_methods = [] + && provided_methods = [] + +let trait_impl_is_empty (trait_impl : trait_impl) : bool = + let { + def_id = _; + name = _; + impl_trait = _; + generics = _; + preds = _; + parent_trait_refs; + consts; + types; + required_methods; + provided_methods; + } = + trait_impl + in + parent_trait_refs = [] && consts = [] && types = [] && required_methods = [] + && provided_methods = [] diff --git a/compiler/ReorderDecls.ml b/compiler/ReorderDecls.ml index fc4744bc..10b68da3 100644 --- a/compiler/ReorderDecls.ml +++ b/compiler/ReorderDecls.ml @@ -38,14 +38,16 @@ let compute_body_fun_deps (e : texpression) : FunIdSet.t = method! visit_qualif _ id = match id.id with - | FunOrOp (Unop _ | Binop _) | Global _ | AdtCons _ | Proj _ -> () + | FunOrOp (Unop _ | Binop _) + | Global _ | AdtCons _ | Proj _ | TraitConst _ -> + () | FunOrOp (Fun fid) -> ( match fid with | Pure _ -> () | FromLlbc (fid, lp_id, rg_id) -> ( match fid with - | Assumed _ -> () - | Regular fid -> + | FunId (Assumed _) -> () + | TraitMethod (_, _, fid) | FunId (Regular fid) -> let id = { def_id = fid; lp_id; rg_id } in ids := FunIdSet.add id !ids)) end diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 38850243..23f618e2 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -9,51 +9,70 @@ module E = Expressions module A = LlbcAst module C = Contexts -(** Substitute types variables and regions in a type. *) -let ty_substitute (rsubst : 'r1 -> 'r2) (tsubst : T.TypeVarId.id -> 'r2 T.ty) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (ty : 'r1 T.ty) : - 'r2 T.ty = - let open T in - let visitor = - object - inherit [_] map_ty - method visit_'r _ r = rsubst r - method! visit_TypeVar _ id = tsubst id +type ('r1, 'r2) subst = { + r_subst : 'r1 -> 'r2; + ty_subst : T.TypeVarId.id -> 'r2 T.ty; + cg_subst : T.ConstGenericVarId.id -> T.const_generic; + (** Substitution from *local* trait clause to trait instance *) + tr_subst : T.TraitClauseId.id -> 'r2 T.trait_instance_id; + (** Substitution for the [Self] trait instance *) + tr_self : 'r2 T.trait_instance_id; +} + +let ty_substitute_visitor (subst : ('r1, 'r2) subst) = + object + inherit [_] T.map_ty + method visit_'r _ r = subst.r_subst r + method! visit_TypeVar _ id = subst.ty_subst id - method! visit_type_var_id _ _ = - (* We should never get here because we reimplemented [visit_TypeVar] *) - raise (Failure "Unexpected") + method! visit_type_var_id _ _ = + (* We should never get here because we reimplemented [visit_TypeVar] *) + raise (Failure "Unexpected") - method! visit_ConstGenericVar _ id = cgsubst id + method! visit_ConstGenericVar _ id = subst.cg_subst id - method! visit_const_generic_var_id _ _ = - (* We should never get here because we reimplemented [visit_Var] *) - raise (Failure "Unexpected") - end - in + method! visit_const_generic_var_id _ _ = + (* We should never get here because we reimplemented [visit_Var] *) + raise (Failure "Unexpected") - visitor#visit_ty () ty + method! visit_Clause _ id = subst.tr_subst id + method! visit_Self _ = subst.tr_self + end -let rty_substitute (rsubst : T.RegionId.id -> T.RegionId.id) - (tsubst : T.TypeVarId.id -> T.rty) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (ty : T.rty) : T.rty = - let rsubst r = - match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) - in - ty_substitute rsubst tsubst cgsubst ty +(** Substitute types variables and regions in a type. -let ety_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (ty : T.ety) : T.ety = - let rsubst r = r in - ty_substitute rsubst tsubst cgsubst ty + **IMPORTANT**: this doesn't normalize the types. + *) +let ty_substitute (subst : ('r1, 'r2) subst) (ty : 'r1 T.ty) : 'r2 T.ty = + let visitor = ty_substitute_visitor subst in + visitor#visit_ty () ty + +(** **IMPORTANT**: this doesn't normalize the types. *) +let trait_ref_substitute (subst : ('r1, 'r2) subst) (tr : 'r1 T.trait_ref) : + 'r2 T.trait_ref = + let visitor = ty_substitute_visitor subst in + visitor#visit_trait_ref () tr + +(** **IMPORTANT**: this doesn't normalize the types. *) +let generic_args_substitute (subst : ('r1, 'r2) subst) (g : 'r1 T.generic_args) + : 'r2 T.generic_args = + let visitor = ty_substitute_visitor subst in + visitor#visit_generic_args () g + +let erase_regions_subst : ('r, T.erased_region) subst = + { + r_subst = (fun _ -> T.Erased); + ty_subst = (fun vid -> T.TypeVar vid); + cg_subst = (fun id -> T.ConstGenericVar id); + tr_subst = (fun id -> T.Clause id); + tr_self = T.Self; + } (** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : T.rty) : T.ety = - ty_substitute - (fun _ -> T.Erased) - (fun vid -> T.TypeVar vid) - (fun id -> T.ConstGenericVar id) - ty +let erase_regions (ty : 'r T.ty) : T.ety = ty_substitute erase_regions_subst ty + +let trait_ref_erase_regions (tr : 'r T.trait_ref) : T.etrait_ref = + trait_ref_substitute erase_regions_subst tr (** Generate fresh regions for region variables. @@ -78,18 +97,20 @@ let fresh_regions_with_substs (region_vars : T.region_var list) : (* Generate the substitution from region var id to region *) let rid_subst id = T.RegionVarId.Map.find id rid_map in (* Generate the substitution from region to region *) - let rsubst r = + let r_subst r = match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) in (* Return *) - (fresh_region_ids, rid_subst, rsubst) + (fresh_region_ids, rid_subst, r_subst) -(** Erase the regions in a type and substitute the type variables *) -let erase_regions_substitute_types (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) - (ty : 'r T.region T.ty) : T.ety = - let rsubst (_ : 'r T.region) : T.erased_region = T.Erased in - ty_substitute rsubst tsubst cgsubst ty +(** Erase the regions in a type and perform a substitution *) +let erase_regions_substitute_types (ty_subst : T.TypeVarId.id -> T.ety) + (cg_subst : T.ConstGenericVarId.id -> T.const_generic) + (tr_subst : T.TraitClauseId.id -> T.etrait_instance_id) + (tr_self : T.etrait_instance_id) (ty : 'r T.ty) : T.ety = + let r_subst (_ : 'r) : T.erased_region = T.Erased in + let subst = { r_subst; ty_subst; cg_subst; tr_subst; tr_self } in + ty_substitute subst ty (** Create a region substitution from a list of region variable ids and a list of regions (with which to substitute the region variable ids *) @@ -146,16 +167,81 @@ let make_const_generic_subst_from_vars (vars : T.const_generic_var list) (List.map (fun (x : T.const_generic_var) -> x.T.index) vars) cgs -(** Instantiate the type variables in an ADT definition, and return, for - every variant, the list of the types of its fields *) -let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) : (T.VariantId.id option * T.rty list) list = - let r_subst = make_region_subst_from_vars def.T.region_params regions in - let ty_subst = make_type_subst_from_vars def.T.type_params types in +(** Create a trait substitution from a list of trait clause ids and a list of + trait refs *) +let make_trait_subst (clause_ids : T.TraitClauseId.id list) + (trs : 'r T.trait_ref list) : T.TraitClauseId.id -> 'r T.trait_instance_id = + let ls = List.combine clause_ids trs in + let mp = + List.fold_left + (fun mp (k, v) -> T.TraitClauseId.Map.add k (T.TraitRef v) mp) + T.TraitClauseId.Map.empty ls + in + fun id -> T.TraitClauseId.Map.find id mp + +let make_trait_subst_from_clauses (clauses : T.trait_clause list) + (trs : 'r T.trait_ref list) : T.TraitClauseId.id -> 'r T.trait_instance_id = + make_trait_subst + (List.map (fun (x : T.trait_clause) -> x.T.clause_id) clauses) + trs + +let make_subst_from_generics (params : T.generic_params) + (args : 'r T.region T.generic_args) + (tr_self : 'r T.region T.trait_instance_id) : + (T.region_var_id T.region, 'r T.region) subst = + let r_subst = make_region_subst_from_vars params.T.regions args.T.regions in + let ty_subst = make_type_subst_from_vars params.T.types args.T.types in let cg_subst = - make_const_generic_subst_from_vars def.T.const_generic_params cgs + make_const_generic_subst_from_vars params.T.const_generics + args.T.const_generics + in + let tr_subst = + make_trait_subst_from_clauses params.T.trait_clauses args.T.trait_refs + in + { r_subst; ty_subst; cg_subst; tr_subst; tr_self } + +let make_subst_from_generics_no_regions : + 'r. + T.generic_params -> + 'r T.generic_args -> + 'r T.trait_instance_id -> + (T.region_var_id T.region, 'r) subst = + fun params args tr_self -> + let r_subst _ = raise (Failure "Unexpected region") in + let ty_subst = make_type_subst_from_vars params.T.types args.T.types in + let cg_subst = + make_const_generic_subst_from_vars params.T.const_generics + args.T.const_generics + in + let tr_subst = + make_trait_subst_from_clauses params.T.trait_clauses args.T.trait_refs + in + { r_subst; ty_subst; cg_subst; tr_subst; tr_self } + +let make_esubst_from_generics (params : T.generic_params) + (generics : T.egeneric_args) (tr_self : T.etrait_instance_id) = + let r_subst _ = T.Erased in + let ty_subst = make_type_subst_from_vars params.types generics.T.types in + let cg_subst = + make_const_generic_subst_from_vars params.const_generics + generics.T.const_generics + in + let tr_subst = + make_trait_subst_from_clauses params.trait_clauses generics.T.trait_refs in + { r_subst; ty_subst; cg_subst; tr_subst; tr_self } + +(** Instantiate the type variables in an ADT definition, and return, for + every variant, the list of the types of its fields. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. +*) +let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) + (generics : T.rgeneric_args) : (T.VariantId.id option * T.rty list) list = + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.T.generics generics tr_self in let (variants_fields : (T.VariantId.id option * T.field list) list) = match def.T.kind with | T.Enum variants -> @@ -171,191 +257,220 @@ let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) in List.map (fun (id, fields) -> - ( id, - List.map - (fun f -> ty_substitute r_subst ty_subst cg_subst f.T.field_ty) - fields )) + (id, List.map (fun f -> ty_substitute subst f.T.field_ty) fields)) variants_fields (** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant *) + of types of the fields for the chosen variant. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. +*) let type_decl_get_instantiated_field_rtypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) : T.rty list = - let r_subst = make_region_subst_from_vars def.T.region_params regions in - let ty_subst = make_type_subst_from_vars def.T.type_params types in - let cg_subst = - make_const_generic_subst_from_vars def.T.const_generic_params cgs - in + (opt_variant_id : T.VariantId.id option) (generics : T.rgeneric_args) : + T.rty list = + (* For now, check that there are no clauses - otherwise we might need + to normalize the types *) + assert (def.generics.trait_clauses = []); + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.T.generics generics tr_self in let fields = TU.type_decl_get_fields def opt_variant_id in - List.map - (fun f -> ty_substitute r_subst ty_subst cg_subst f.T.field_ty) - fields + List.map (fun f -> ty_substitute subst f.T.field_ty) fields (** Return the types of the properly instantiated ADT's variant, provided a - context *) + context. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. +*) let ctx_adt_get_instantiated_field_rtypes (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) : T.rty list = + (generics : T.rgeneric_args) : T.rty list = let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_rtypes def opt_variant_id regions types cgs + type_decl_get_instantiated_field_rtypes def opt_variant_id generics (** Return the types of the properly instantiated ADT value (note that - here, ADT is understood in its broad meaning: ADT, assumed value or tuple) *) + here, ADT is understood in its broad meaning: ADT, assumed value or tuple). + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. + *) let ctx_adt_value_get_instantiated_field_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) - (region_params : T.RegionId.id T.region list) (type_params : T.rty list) - (cg_params : T.const_generic list) : T.rty list = + (adt : V.adt_value) (id : T.type_id) (generics : T.rgeneric_args) : + T.rty list = match id with | T.AdtId id -> (* Retrieve the types of the fields *) - ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id - region_params type_params cg_params + ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id generics | T.Tuple -> - assert (List.length region_params = 0); - type_params + assert (generics.regions = []); + generics.types | T.Assumed aty -> ( match aty with - | T.Box | T.Vec -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - assert (List.length cg_params = 0); - type_params - | T.Option -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - assert (List.length cg_params = 0); - if adt.V.variant_id = Some T.option_some_id then type_params - else if adt.V.variant_id = Some T.option_none_id then [] - else raise (Failure "Unreachable") - | T.Range -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - assert (List.length cg_params = 0); - type_params + | T.Box -> + assert (generics.regions = []); + assert (List.length generics.types = 1); + assert (generics.const_generics = []); + generics.types | T.Array | T.Slice | T.Str -> (* Those types don't have fields *) raise (Failure "Unreachable")) (** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant *) + of types of the fields for the chosen variant. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. +*) let type_decl_get_instantiated_field_etypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (types : T.ety list) - (cgs : T.const_generic list) : T.ety list = - let ty_subst = make_type_subst_from_vars def.T.type_params types in - let cg_subst = - make_const_generic_subst_from_vars def.T.const_generic_params cgs + (opt_variant_id : T.VariantId.id option) (generics : T.egeneric_args) : + T.ety list = + (* For now, check that there are no clauses - otherwise we might need + to normalize the types *) + assert (def.generics.trait_clauses = []); + (* There shouldn't be any reference to Self *) + let tr_self : T.erased_region T.trait_instance_id = + T.UnknownTrait __FUNCTION__ + in + let { r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = + make_esubst_from_generics def.T.generics generics tr_self in let fields = TU.type_decl_get_fields def opt_variant_id in List.map - (fun f -> erase_regions_substitute_types ty_subst cg_subst f.T.field_ty) + (fun (f : T.field) -> + erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self + f.T.field_ty) fields (** Return the types of the properly instantiated ADT's variant, provided a - context *) + context. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. + *) let ctx_adt_get_instantiated_field_etypes (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (types : T.ety list) (cgs : T.const_generic list) : T.ety list = + (generics : T.egeneric_args) : T.ety list = let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_etypes def opt_variant_id types cgs + type_decl_get_instantiated_field_etypes def opt_variant_id generics -let statement_substitute_visitor (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) = +let statement_substitute_visitor + (subst : (T.erased_region, T.erased_region) subst) = + (* Keep in synch with [ty_substitute_visitor] *) object inherit [_] A.map_statement - method! visit_ety _ ty = ety_substitute tsubst cgsubst ty - method! visit_ConstGenericVar _ id = cgsubst id + method! visit_'r _ r = subst.r_subst r + method! visit_TypeVar _ id = subst.ty_subst id + + method! visit_type_var_id _ _ = + (* We should never get here because we reimplemented [visit_TypeVar] *) + raise (Failure "Unexpected") + + method! visit_ConstGenericVar _ id = subst.cg_subst id method! visit_const_generic_var_id _ _ = (* We should never get here because we reimplemented [visit_Var] *) raise (Failure "Unexpected") + + method! visit_Clause _ id = subst.tr_subst id + method! visit_Self _ = subst.tr_self end (** Apply a type substitution to a place *) -let place_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (p : E.place) : - E.place = +let place_substitute (subst : (T.erased_region, T.erased_region) subst) + (p : E.place) : E.place = (* There is in fact nothing to do *) - (statement_substitute_visitor tsubst cgsubst)#visit_place () p + (statement_substitute_visitor subst)#visit_place () p (** Apply a type substitution to an operand *) -let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (op : E.operand) : - E.operand = - (statement_substitute_visitor tsubst cgsubst)#visit_operand () op +let operand_substitute (subst : (T.erased_region, T.erased_region) subst) + (op : E.operand) : E.operand = + (statement_substitute_visitor subst)#visit_operand () op (** Apply a type substitution to an rvalue *) -let rvalue_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (rv : E.rvalue) : - E.rvalue = - (statement_substitute_visitor tsubst cgsubst)#visit_rvalue () rv +let rvalue_substitute (subst : (T.erased_region, T.erased_region) subst) + (rv : E.rvalue) : E.rvalue = + (statement_substitute_visitor subst)#visit_rvalue () rv (** Apply a type substitution to an assertion *) -let assertion_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (a : A.assertion) : - A.assertion = - (statement_substitute_visitor tsubst cgsubst)#visit_assertion () a +let assertion_substitute (subst : (T.erased_region, T.erased_region) subst) + (a : A.assertion) : A.assertion = + (statement_substitute_visitor subst)#visit_assertion () a (** Apply a type substitution to a call *) -let call_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (call : A.call) : - A.call = - (statement_substitute_visitor tsubst cgsubst)#visit_call () call +let call_substitute (subst : (T.erased_region, T.erased_region) subst) + (call : A.call) : A.call = + (statement_substitute_visitor subst)#visit_call () call (** Apply a type substitution to a statement *) -let statement_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (st : A.statement) : - A.statement = - (statement_substitute_visitor tsubst cgsubst)#visit_statement () st +let statement_substitute (subst : (T.erased_region, T.erased_region) subst) + (st : A.statement) : A.statement = + (statement_substitute_visitor subst)#visit_statement () st (** Apply a type substitution to a function body. Return the local variables and the body. *) -let fun_body_substitute_in_body (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (body : A.fun_body) : +let fun_body_substitute_in_body + (subst : (T.erased_region, T.erased_region) subst) (body : A.fun_body) : A.var list * A.statement = - let rsubst r = r in let locals = List.map - (fun (v : A.var) -> - { v with A.var_ty = ty_substitute rsubst tsubst cgsubst v.A.var_ty }) + (fun (v : A.var) -> { v with A.var_ty = ty_substitute subst v.A.var_ty }) body.A.locals in - let body = statement_substitute tsubst cgsubst body.body in + let body = statement_substitute subst body.body in (locals, body) -(** Substitute a function signature *) +let trait_type_constraint_substitute (subst : ('r1, 'r2) subst) + (ttc : 'r1 T.trait_type_constraint) : 'r2 T.trait_type_constraint = + let { T.trait_ref; generics; type_name; ty } = ttc in + let visitor = ty_substitute_visitor subst in + let trait_ref = visitor#visit_trait_ref () trait_ref in + let generics = visitor#visit_generic_args () generics in + let ty = visitor#visit_ty () ty in + { T.trait_ref; generics; type_name; ty } + +(** Substitute a function signature. + + **IMPORTANT:** this function doesn't normalize the types. + *) let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (rsubst : T.RegionVarId.id -> T.RegionId.id) - (tsubst : T.TypeVarId.id -> T.rty) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (sg : A.fun_sig) : - A.inst_fun_sig = - let rsubst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = - match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) + (r_subst : T.RegionVarId.id -> T.RegionId.id) + (ty_subst : T.TypeVarId.id -> T.rty) + (cg_subst : T.ConstGenericVarId.id -> T.const_generic) + (tr_subst : T.TraitClauseId.id -> T.rtrait_instance_id) + (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + let r_subst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = + match r with T.Static -> T.Static | T.Var rid -> T.Var (r_subst rid) in - let inputs = List.map (ty_substitute rsubst' tsubst cgsubst) sg.A.inputs in - let output = ty_substitute rsubst' tsubst cgsubst sg.A.output in + let subst = { r_subst = r_subst'; ty_subst; cg_subst; tr_subst; tr_self } in + let inputs = List.map (ty_substitute subst) sg.A.inputs in + let output = ty_substitute subst sg.A.output in let subst_region_group (rg : T.region_var_group) : A.abs_region_group = let id = asubst rg.id in - let regions = List.map rsubst rg.regions in + let regions = List.map r_subst rg.regions in let parents = List.map asubst rg.parents in { id; regions; parents } in let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in - { A.regions_hierarchy; inputs; output } + let trait_type_constraints = + List.map + (trait_type_constraint_substitute subst) + sg.preds.trait_type_constraints + in + { A.inputs; output; regions_hierarchy; trait_type_constraints } -(** Substitute type variable identifiers in a type *) -let ty_substitute_ids (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : 'r T.ty) +(** Substitute variable identifiers in a type *) +let ty_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : 'r T.ty) : 'r T.ty = let open T in let visitor = object inherit [_] map_ty method visit_'r _ r = r - method! visit_type_var_id _ id = tsubst id - method! visit_const_generic_var_id _ id = cgsubst id + method! visit_type_var_id _ id = ty_subst id + method! visit_const_generic_var_id _ id = cg_subst id end in @@ -371,10 +486,10 @@ let ty_substitute_ids (tsubst : T.TypeVarId.id -> T.TypeVarId.id) [visit_'r] if we define a class which visits objects of types [ety] and [rty] while inheriting a class which visit [ty]... *) -let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) +let subst_ids_visitor (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) = @@ -383,10 +498,10 @@ let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) inherit [_] T.map_ty method visit_'r _ r = - match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) + match r with T.Static -> T.Static | T.Var rid -> T.Var (r_subst rid) - method! visit_type_var_id _ id = tsubst id - method! visit_const_generic_var_id _ id = cgsubst id + method! visit_type_var_id _ id = ty_subst id + method! visit_const_generic_var_id _ id = cg_subst id end in @@ -395,7 +510,7 @@ let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) inherit [_] C.map_env method! visit_borrow_id _ bid = bsubst bid method! visit_loan_id _ bid = bsubst bid - method! visit_ety _ ty = ty_substitute_ids tsubst cgsubst ty + method! visit_ety _ ty = ty_substitute_ids ty_subst cg_subst ty method! visit_rty env ty = subst_rty#visit_ty env ty method! visit_symbolic_value_id _ id = ssubst id @@ -405,7 +520,7 @@ let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) (** We *do* visit meta-values *) method! visit_mvalue env v = self#visit_typed_value env v - method! visit_region_id _ id = rsubst id + method! visit_region_id _ id = r_subst id method! visit_region_var_id _ id = rvsubst id method! visit_abstraction_id _ id = asubst id end @@ -425,20 +540,20 @@ let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) method visit_env (env : C.env) : C.env = visitor#visit_env () env end -let typed_value_subst_ids (rsubst : T.RegionId.id -> T.RegionId.id) +let typed_value_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_value) : V.typed_value = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor rsubst rvsubst tsubst cgsubst ssubst bsubst asubst) + (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) #visit_typed_value v -let typed_value_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) +let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (v : V.typed_value) : V.typed_value = - typed_value_subst_ids rsubst + typed_value_subst_ids r_subst (fun x -> x) (fun x -> x) (fun x -> x) @@ -446,41 +561,41 @@ let typed_value_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) (fun x -> x) v -let typed_avalue_subst_ids (rsubst : T.RegionId.id -> T.RegionId.id) +let typed_avalue_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_avalue) : V.typed_avalue = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor rsubst rvsubst tsubst cgsubst ssubst bsubst asubst) + (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) #visit_typed_avalue v -let abs_subst_ids (rsubst : T.RegionId.id -> T.RegionId.id) +let abs_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : V.abs) : V.abs = - (subst_ids_visitor rsubst rvsubst tsubst cgsubst ssubst bsubst asubst) + (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) #visit_abs x -let env_subst_ids (rsubst : T.RegionId.id -> T.RegionId.id) +let env_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : C.env) : C.env = - (subst_ids_visitor rsubst rvsubst tsubst cgsubst ssubst bsubst asubst) + (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) #visit_env x -let typed_avalue_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) +let typed_avalue_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : V.typed_avalue) : V.typed_avalue = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor rsubst + (subst_ids_visitor r_subst (fun x -> x) (fun x -> x) (fun x -> x) @@ -490,9 +605,9 @@ let typed_avalue_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) #visit_typed_avalue x -let env_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) (x : C.env) : C.env - = - (subst_ids_visitor rsubst +let env_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : C.env) : + C.env = + (subst_ids_visitor r_subst (fun x -> x) (fun x -> x) (fun x -> x) diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index 7dc94dcd..4df8fec7 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -29,7 +29,7 @@ type mplace = { [@@deriving show] type call_id = - | Fun of A.fun_id * V.FunCallId.id + | Fun of A.fun_id_or_trait_method_ref * V.FunCallId.id (** A "regular" function (i.e., a function which is not a primitive operation) *) | Unop of E.unop | Binop of E.binop @@ -43,10 +43,7 @@ type call = { borrows (we need to perform lookups). *) abstractions : V.AbstractionId.id list; - (* TODO: rename to "...args" *) - type_params : T.ety list; - (* TODO: rename to "...args" *) - const_generic_params : T.const_generic list; + generics : T.egeneric_args; args : V.typed_value list; args_places : mplace option list; (** Meta information *) dest : V.symbolic_value; @@ -79,6 +76,9 @@ class ['self] iter_expression_base = method visit_loop_id : 'env -> V.loop_id -> unit = fun _ _ -> () method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () + method visit_const_generic_var_id : 'env -> T.const_generic_var_id -> unit = + fun _ _ -> () + method visit_symbolic_value_id : 'env -> V.symbolic_value_id -> unit = fun _ _ -> () @@ -120,6 +120,9 @@ class ['self] iter_expression_base = method visit_symbolic_expansion : 'env -> V.symbolic_expansion -> unit = fun _ _ -> () + + method visit_etrait_ref : 'env -> T.etrait_ref -> unit = fun _ _ -> () + method visit_egeneric_args : 'env -> T.egeneric_args -> unit = fun _ _ -> () end (** **Rem.:** here, {!expression} is not at all equivalent to the expressions @@ -171,14 +174,15 @@ type expression = * expression (** We introduce a new symbolic value, equal to some other value. - This is used for instance when reorganizing the environment to compute - fixed points: we duplicate some shared symbolic values to destructure - the shared values, in order to make the environment a bit more general - (while losing precision of course). + This is used for instance when reorganizing the environment to compute + fixed points: we duplicate some shared symbolic values to destructure + the shared values, in order to make the environment a bit more general + (while losing precision of course). We also use it to introduce symbolic + values when evaluating constant generics, or trait constants. - The context is the evaluation context from before introducing the new - value. It has the same purpose as for the {!Return} case. - *) + The context is the evaluation context from before introducing the new + value. It has the same purpose as for the {!Return} case. + *) | ForwardEnd of Contexts.eval_ctx * V.typed_value symbolic_value_id_map option @@ -253,6 +257,11 @@ and value_aggregate = | SingleValue of V.typed_value (** Regular case *) | Array of V.typed_value list (** This is used when introducing array aggregates *) + | ConstGenericValue of T.const_generic_var_id + (** This is used when evaluating a const generic value: in the interpreter, + we introduce a fresh symbolic value. *) + | TraitConstValue of T.etrait_ref * T.egeneric_args * string + (** A trait constant value *) [@@deriving show, visitors diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 3512270a..2ce8c706 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -4,6 +4,7 @@ open Pure open PureUtils module Id = Identifiers module C = Contexts +module A = LlbcAst module S = SymbolicAst module TA = TypesAnalysis module L = Logging @@ -52,6 +53,9 @@ type fun_context = { type global_context = { llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t } [@@deriving show] +type trait_decls_context = A.trait_decl A.TraitDeclId.Map.t [@@deriving show] +type trait_impls_context = A.trait_impl A.TraitImplId.Map.t [@@deriving show] + (** Whenever we translate a function call or an ended abstraction, we store the related information (this is useful when translating ended children abstractions). @@ -106,8 +110,7 @@ type loop_info = { loop_id : LoopId.id; input_vars : var list; input_svl : V.symbolic_value list; - type_args : ty list; - const_generic_args : const_generic list; + generics : generic_args; forward_inputs : texpression list option; (** The forward inputs are initialized at [None] *) forward_output_no_state_no_result : var option; @@ -120,6 +123,8 @@ type bs_ctx = { type_context : type_context; fun_context : fun_context; global_context : global_context; + trait_decls_ctx : trait_decls_context; + trait_impls_ctx : trait_impls_context; fun_decl : A.fun_decl; bid : T.RegionGroupId.id option; (** TODO: rename *) sg : fun_sig; @@ -201,34 +206,11 @@ type bs_ctx = { } [@@deriving show] -let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = - let env = VarId.Map.empty in - let ctx = - { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env; - } - in - let _ = PureTypeCheck.check_typed_pattern ctx v in - () - -let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = - let env = VarId.Map.empty in - let ctx = - { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env; - } - in - PureTypeCheck.check_texpression ctx e - (* TODO: move *) let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.Ast.ast_formatter = Print.Ast.decls_and_fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls - ctx.fun_decl + ctx.trait_decls_ctx ctx.trait_impls_ctx ctx.fun_decl let bs_ctx_to_ctx_formatter (ctx : bs_ctx) : Print.Contexts.ctx_formatter = let rvar_to_string = Print.Types.region_var_id_to_string in @@ -246,16 +228,25 @@ let bs_ctx_to_ctx_formatter (ctx : bs_ctx) : Print.Contexts.ctx_formatter = adt_variant_to_string = ast_fmt.adt_variant_to_string; var_id_to_string; adt_field_names = ast_fmt.adt_field_names; + trait_decl_id_to_string = ast_fmt.trait_decl_id_to_string; + trait_impl_id_to_string = ast_fmt.trait_impl_id_to_string; + trait_clause_id_to_string = ast_fmt.trait_clause_id_to_string; } let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = - let type_params = ctx.fun_decl.signature.type_params in - let cg_params = ctx.fun_decl.signature.const_generic_params in + let generics = ctx.fun_decl.signature.generics in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + PrintPure.mk_ast_formatter type_decls fun_decls global_decls + ctx.trait_decls_ctx ctx.trait_impls_ctx generics.types + generics.const_generics + +let ctx_egeneric_args_to_string (ctx : bs_ctx) (args : T.egeneric_args) : string + = + let fmt = bs_ctx_to_ctx_formatter ctx in + let fmt = Print.PC.ctx_to_etype_formatter fmt in + Print.PT.egeneric_args_to_string fmt args let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = let fmt = bs_ctx_to_ctx_formatter ctx in @@ -277,12 +268,11 @@ let rty_to_string (ctx : bs_ctx) (ty : T.rty) : string = Print.PT.rty_to_string fmt ty let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = - let type_params = def.type_params in - let cg_params = def.const_generic_params in let type_decls = ctx.type_context.llbc_type_decls in let global_decls = ctx.global_context.llbc_global_decls in let fmt = - PrintPure.mk_type_formatter type_decls global_decls type_params cg_params + PrintPure.mk_type_formatter type_decls global_decls ctx.trait_decls_ctx + ctx.trait_impls_ctx def.generics.types def.generics.const_generics in PrintPure.type_decl_to_string fmt def @@ -291,26 +281,27 @@ let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = PrintPure.texpression_to_string fmt false "" " " e let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = - let type_params = sg.type_params in - let cg_params = sg.const_generic_params in + let type_params = sg.generics.types in + let cg_params = sg.generics.const_generics in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + PrintPure.mk_ast_formatter type_decls fun_decls global_decls + ctx.trait_decls_ctx ctx.trait_impls_ctx type_params cg_params in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = - let type_params = def.signature.type_params in - let cg_params = def.signature.const_generic_params in + let generics = def.signature.generics in + let type_params = generics.types in + let cg_params = generics.const_generics in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + PrintPure.mk_ast_formatter type_decls fun_decls global_decls + ctx.trait_decls_ctx ctx.trait_impls_ctx type_params cg_params in PrintPure.fun_decl_to_string fmt def @@ -328,17 +319,18 @@ let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = Print.Values.abs_to_string fmt verbose indent indent_incr abs let get_instantiated_fun_sig (fun_id : A.fun_id) - (back_id : T.RegionGroupId.id option) (tys : ty list) - (cgs : const_generic list) (ctx : bs_ctx) : inst_fun_sig = + (back_id : T.RegionGroupId.id option) (generics : generic_args) + (ctx : bs_ctx) : inst_fun_sig = (* Lookup the non-instantiated function signature *) let sg = (RegularFunIdNotLoopMap.find (fun_id, back_id) ctx.fun_context.fun_sigs).sg in (* Create the substitution *) - let tsubst = make_type_subst sg.type_params tys in - let cgsubst = make_const_generic_subst sg.const_generic_params cgs in + (* There shouldn't be any reference to Self *) + let tr_self = UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics sg.generics generics tr_self in (* Apply *) - fun_sig_substitute tsubst cgsubst sg + fun_sig_substitute subst sg let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : T.type_decl = @@ -351,77 +343,128 @@ let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : (* TODO: move *) let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = - let id = (A.Regular def_id, back_id) in + let id = (E.Regular def_id, back_id) in (RegularFunIdNotLoopMap.find id ctx.fun_context.fun_sigs).sg -let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) - (args : texpression list) (ctx : bs_ctx) : bs_ctx = - let calls = ctx.calls in - assert (not (V.FunCallId.Map.mem call_id calls)); - let info = - { forward; forward_inputs = args; backwards = T.RegionGroupId.Map.empty } - in - let calls = V.FunCallId.Map.add call_id info calls in - { ctx with calls } - -(** [back_args]: the *additional* list of inputs received by the backward function *) -let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) - (back_id : T.RegionGroupId.id) (back_args : texpression list) (ctx : bs_ctx) - : bs_ctx * fun_or_op_id = - (* Insert the abstraction in the call informations *) - let info = V.FunCallId.Map.find call_id ctx.calls in - assert (not (T.RegionGroupId.Map.mem back_id info.backwards)); - let backwards = - T.RegionGroupId.Map.add back_id (abs, back_args) info.backwards - in - let info = { info with backwards } in - let calls = V.FunCallId.Map.add call_id info ctx.calls in - (* Insert the abstraction in the abstractions map *) - let abstractions = ctx.abstractions in - assert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)); - let abstractions = - V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions - in - (* Retrieve the fun_id *) - let fun_id = - match info.forward.call_id with - | S.Fun (fid, _) -> Fun (FromLlbc (fid, None, Some back_id)) - | S.Unop _ | S.Binop _ -> raise (Failure "Unreachable") - in - (* Update the context and return *) - ({ ctx with calls; abstractions }, fun_id) +(* Some generic translation functions (we need to translate different "flavours" + of types: sty, forward types, backward types, etc.) *) +let rec translate_generic_args (translate_ty : 'r T.ty -> ty) + (generics : 'r T.generic_args) : generic_args = + (* We ignore the regions: if they didn't cause trouble for the symbolic execution, + then everything's fine *) + let types = List.map translate_ty generics.types in + let const_generics = generics.const_generics in + let trait_refs = + List.map (translate_trait_ref translate_ty) generics.trait_refs + in + { types; const_generics; trait_refs } + +and translate_trait_ref (translate_ty : 'r T.ty -> ty) (tr : 'r T.trait_ref) : + trait_ref = + let trait_id = translate_trait_instance_id translate_ty tr.trait_id in + let generics = translate_generic_args translate_ty tr.generics in + let trait_decl_ref = + translate_trait_decl_ref translate_ty tr.trait_decl_ref + in + { trait_id; generics; trait_decl_ref } + +and translate_trait_decl_ref (translate_ty : 'r T.ty -> ty) + (tr : 'r T.trait_decl_ref) : trait_decl_ref = + let decl_generics = translate_generic_args translate_ty tr.decl_generics in + { trait_decl_id = tr.trait_decl_id; decl_generics } + +and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) + (id : 'r T.trait_instance_id) : trait_instance_id = + let translate_trait_instance_id = translate_trait_instance_id translate_ty in + match id with + | T.Self -> Self + | TraitImpl id -> TraitImpl id + | BuiltinOrAuto _ -> + (* We should have eliminated those in the prepasses *) + raise (Failure "Unreachable") + | Clause id -> Clause id + | ParentClause (inst_id, decl_id, clause_id) -> + let inst_id = translate_trait_instance_id inst_id in + ParentClause (inst_id, decl_id, clause_id) + | ItemClause (inst_id, decl_id, item_name, clause_id) -> + let inst_id = translate_trait_instance_id inst_id in + ItemClause (inst_id, decl_id, item_name, clause_id) + | TraitRef tr -> TraitRef (translate_trait_ref translate_ty tr) + | FnPointer _ -> raise (Failure "TODO") + | UnknownTrait s -> raise (Failure ("Unknown trait found: " ^ s)) let rec translate_sty (ty : T.sty) : ty = let translate = translate_sty in match ty with - | T.Adt (type_id, regions, tys, cgs) -> ( - (* Can't translate types with regions for now *) - assert (regions = []); - let tys = List.map translate tys in + | T.Adt (type_id, generics) -> ( + let generics = translate_sgeneric_args generics in match type_id with - | T.AdtId adt_id -> Adt (AdtId adt_id, tys, cgs) - | T.Tuple -> mk_simpl_tuple_ty tys + | T.AdtId adt_id -> Adt (AdtId adt_id, generics) + | T.Tuple -> + assert (generics.const_generics = []); + mk_simpl_tuple_ty generics.types | T.Assumed aty -> ( match aty with - | T.Vec -> Adt (Assumed Vec, tys, cgs) - | T.Option -> Adt (Assumed Option, tys, cgs) | T.Box -> ( (* Eliminate the boxes *) - match tys with + match generics.types with | [ ty ] -> ty | _ -> raise (Failure "Box/vec/option type with incorrect number of arguments") ) - | T.Array -> Adt (Assumed Array, tys, cgs) - | T.Slice -> Adt (Assumed Slice, tys, cgs) - | T.Str -> Adt (Assumed Str, tys, cgs) - | T.Range -> Adt (Assumed Range, tys, cgs))) + | T.Array -> Adt (Assumed Array, generics) + | T.Slice -> Adt (Assumed Slice, generics) + | T.Str -> Adt (Assumed Str, generics))) | TypeVar vid -> TypeVar vid | Literal ty -> Literal ty | Never -> raise (Failure "Unreachable") | Ref (_, rty, _) -> translate rty + | RawPtr (ty, rkind) -> + let mut = match rkind with Mut -> Mut | Shared -> Const in + let ty = translate ty in + let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in + Adt (Assumed (RawPtr mut), generics) + | TraitType (trait_ref, generics, type_name) -> + let trait_ref = translate_strait_ref trait_ref in + let generics = translate_sgeneric_args generics in + TraitType (trait_ref, generics, type_name) + | Arrow _ -> raise (Failure "TODO") + +and translate_sgeneric_args (generics : T.sgeneric_args) : generic_args = + translate_generic_args translate_sty generics + +and translate_strait_ref (tr : T.strait_ref) : trait_ref = + translate_trait_ref translate_sty tr + +and translate_strait_instance_id (id : T.strait_instance_id) : trait_instance_id + = + translate_trait_instance_id translate_sty id + +let translate_trait_clause (clause : T.trait_clause) : trait_clause = + let { T.clause_id; meta = _; trait_id; generics } = clause in + let generics = translate_sgeneric_args generics in + { clause_id; trait_id; generics } + +let translate_strait_type_constraint (ttc : T.strait_type_constraint) : + trait_type_constraint = + let { T.trait_ref; generics; type_name; ty } = ttc in + let trait_ref = translate_strait_ref trait_ref in + let generics = translate_sgeneric_args generics in + let ty = translate_sty ty in + { trait_ref; generics; type_name; ty } + +let translate_predicates (preds : T.predicates) : predicates = + let trait_type_constraints = + List.map translate_strait_type_constraint preds.trait_type_constraints + in + { trait_type_constraints } + +let translate_generic_params (generics : T.generic_params) : generic_params = + let { T.regions = _; types; const_generics; trait_clauses } = generics in + let trait_clauses = List.map translate_trait_clause trait_clauses in + { types; const_generics; trait_clauses } let translate_field (f : T.field) : field = let field_name = f.field_name in @@ -452,15 +495,16 @@ let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = point of moving this definition for now. *) let translate_type_decl (def : T.type_decl) : type_decl = - (* Translate *) let def_id = def.T.def_id in let name = def.name in + let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) - assert (def.region_params = []); - let type_params = def.type_params in - let const_generic_params = def.const_generic_params in + assert (regions = []); + let trait_clauses = List.map translate_trait_clause trait_clauses in + let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.T.kind in - { def_id; name; type_params; const_generic_params; kind } + let preds = translate_predicates def.preds in + { def_id; name; generics; kind; preds } let translate_type_id (id : T.type_id) : type_id = match id with @@ -468,12 +512,9 @@ let translate_type_id (id : T.type_id) : type_id = | T.Assumed aty -> let aty = match aty with - | T.Vec -> Vec - | T.Option -> Option | T.Array -> Array | T.Slice -> Slice | T.Str -> Str - | T.Range -> Range | T.Box -> (* Boxes have to be eliminated: this type id shouldn't be translated *) @@ -488,28 +529,26 @@ let translate_type_id (id : T.type_id) : type_id = let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = let translate = translate_fwd_ty type_infos in match ty with - | T.Adt (type_id, regions, tys, cgs) -> ( - (* Can't translate types with regions for now *) - assert (regions = []); - (* Translate the type parameters *) - let t_tys = List.map translate tys in + | T.Adt (type_id, generics) -> ( + let t_generics = translate_fwd_generic_args type_infos generics in (* Eliminate boxes and simplify tuples *) match type_id with - | AdtId _ - | T.Assumed (T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> - (* No general parametricity for now *) - assert (not (List.exists (TypesUtils.ty_has_borrows type_infos) tys)); + | AdtId _ | T.Assumed (T.Array | T.Slice | T.Str) -> let type_id = translate_type_id type_id in - Adt (type_id, t_tys, cgs) + Adt (type_id, t_generics) | Tuple -> (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the identity *) - mk_simpl_tuple_ty t_tys + mk_simpl_tuple_ty t_generics.types | T.Assumed T.Box -> ( (* We eliminate boxes *) (* No general parametricity for now *) - assert (not (List.exists (TypesUtils.ty_has_borrows type_infos) tys)); - match t_tys with + assert ( + not + (List.exists + (TypesUtils.ty_has_borrows type_infos) + generics.types)); + match t_generics.types with | [ bty ] -> bty | _ -> raise @@ -520,12 +559,40 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = | Never -> raise (Failure "Unreachable") | Literal lty -> Literal lty | Ref (_, rty, _) -> translate rty + | RawPtr (ty, rkind) -> + let mut = match rkind with Mut -> Mut | Shared -> Const in + let ty = translate ty in + let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in + Adt (Assumed (RawPtr mut), generics) + | TraitType (trait_ref, generics, type_name) -> + let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + let generics = translate_fwd_generic_args type_infos generics in + TraitType (trait_ref, generics, type_name) + | Arrow _ -> raise (Failure "TODO") + +and translate_fwd_generic_args (type_infos : TA.type_infos) + (generics : 'r T.generic_args) : generic_args = + translate_generic_args (translate_fwd_ty type_infos) generics + +and translate_fwd_trait_ref (type_infos : TA.type_infos) (tr : 'r T.trait_ref) : + trait_ref = + translate_trait_ref (translate_fwd_ty type_infos) tr + +and translate_fwd_trait_instance_id (type_infos : TA.type_infos) + (id : 'r T.trait_instance_id) : trait_instance_id = + translate_trait_instance_id (translate_fwd_ty type_infos) id (** Simply calls [translate_fwd_ty] *) let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : 'r T.ty) : ty = let type_infos = ctx.type_context.type_infos in translate_fwd_ty type_infos ty +(** Simply calls [translate_fwd_generic_args] *) +let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : 'r T.generic_args) + : generic_args = + let type_infos = ctx.type_context.type_infos in + translate_fwd_generic_args type_infos generics + (** Translate a type, when some regions may have ended. We return an option, because the translated type may be empty. @@ -538,30 +605,40 @@ let rec translate_back_ty (type_infos : TA.type_infos) (* A small helper for "leave" types *) let wrap ty = if inside_mut then Some ty else None in match ty with - | T.Adt (type_id, _, tys, cgs) -> ( + | T.Adt (type_id, generics) -> ( match type_id with - | T.AdtId _ - | Assumed (T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> - (* Don't accept ADTs (which are not tuples) with borrows for now *) - assert (not (TypesUtils.ty_has_borrows type_infos ty)); + | T.AdtId _ | Assumed (T.Array | T.Slice | T.Str) -> let type_id = translate_type_id type_id in if inside_mut then - let tys_t = List.filter_map translate tys in - Some (Adt (type_id, tys_t, cgs)) - else None + (* We do not want to filter anything, so we translate the generics + as "forward" types *) + let generics = translate_fwd_generic_args type_infos generics in + Some (Adt (type_id, generics)) + else + (* If not inside a mutable reference: check if at least one + of the generics contains a mutable reference (i.e., is not + translated to `None`. If yes, keep the whole type, and + translate all the generics as "forward" types (the backward + function will extract the proper information from the ADT value) + *) + let types = List.filter_map translate generics.types in + if types <> [] then + let generics = translate_fwd_generic_args type_infos generics in + Some (Adt (type_id, generics)) + else None | Assumed T.Box -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) assert (not (TypesUtils.ty_has_borrows type_infos ty)); (* Eliminate the box *) - match tys with + match generics.types with | [ bty ] -> translate bty | _ -> raise (Failure "Unreachable: boxes receive exactly one type parameter") ) | T.Tuple -> ( - (* Tuples can contain borrows (which we eliminated) *) - let tys_t = List.filter_map translate tys in + (* Tuples can contain borrows (which we eliminate) *) + let tys_t = List.filter_map translate generics.types in match tys_t with | [] -> None | _ -> @@ -582,6 +659,17 @@ let rec translate_back_ty (type_infos : TA.type_infos) if keep_region r then translate_back_ty type_infos keep_region inside_mut rty else None) + | RawPtr _ -> + (* TODO: not sure what to do here *) + None + | TraitType (trait_ref, generics, type_name) -> + assert (generics.regions = []); + (* Translate the trait ref and the generics as "forward" generics - + we do not want to filter any type *) + let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + let generics = translate_fwd_generic_args type_infos generics in + Some (TraitType (trait_ref, generics, type_name)) + | Arrow _ -> raise (Failure "TODO") (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) @@ -589,6 +677,80 @@ let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) let type_infos = ctx.type_context.type_infos in translate_back_ty type_infos keep_region inside_mut ty +let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = + let const_generics = + T.ConstGenericVarId.Map.of_list + (List.map + (fun (cg : T.const_generic_var) -> + (cg.index, ctx_translate_fwd_ty ctx (T.Literal cg.ty))) + ctx.sg.generics.const_generics) + in + let env = VarId.Map.empty in + { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env; + const_generics; + } + +let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = + let ctx = mk_type_check_ctx ctx in + let _ = PureTypeCheck.check_typed_pattern ctx v in + () + +let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = + if !Config.type_check_pure_code then + let ctx = mk_type_check_ctx ctx in + PureTypeCheck.check_texpression ctx e + +let translate_fun_id_or_trait_method_ref (ctx : bs_ctx) + (id : A.fun_id_or_trait_method_ref) : fun_id_or_trait_method_ref = + match id with + | FunId fun_id -> FunId fun_id + | TraitMethod (trait_ref, method_name, fun_decl_id) -> + let type_infos = ctx.type_context.type_infos in + let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + TraitMethod (trait_ref, method_name, fun_decl_id) + +let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) + (args : texpression list) (ctx : bs_ctx) : bs_ctx = + let calls = ctx.calls in + assert (not (V.FunCallId.Map.mem call_id calls)); + let info = + { forward; forward_inputs = args; backwards = T.RegionGroupId.Map.empty } + in + let calls = V.FunCallId.Map.add call_id info calls in + { ctx with calls } + +(** [back_args]: the *additional* list of inputs received by the backward function *) +let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) + (back_id : T.RegionGroupId.id) (back_args : texpression list) (ctx : bs_ctx) + : bs_ctx * fun_or_op_id = + (* Insert the abstraction in the call informations *) + let info = V.FunCallId.Map.find call_id ctx.calls in + assert (not (T.RegionGroupId.Map.mem back_id info.backwards)); + let backwards = + T.RegionGroupId.Map.add back_id (abs, back_args) info.backwards + in + let info = { info with backwards } in + let calls = V.FunCallId.Map.add call_id info ctx.calls in + (* Insert the abstraction in the abstractions map *) + let abstractions = ctx.abstractions in + assert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)); + let abstractions = + V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions + in + (* Retrieve the fun_id *) + let fun_id = + match info.forward.call_id with + | S.Fun (fid, _) -> + let fid = translate_fun_id_or_trait_method_ref ctx fid in + Fun (FromLlbc (fid, None, Some back_id)) + | S.Unop _ | S.Binop _ -> raise (Failure "Unreachable") + in + (* Update the context and return *) + ({ ctx with calls; abstractions }, fun_id) + (** List the ancestors of an abstraction *) let list_ancestor_abstractions_ids (ctx : bs_ctx) (abs : V.abs) (call_id : V.FunCallId.id) : V.AbstractionId.id list = @@ -642,10 +804,10 @@ let mk_fuel_input_as_list (ctx : bs_ctx) (info : fun_effect_info) : (** Small utility. *) let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (fun_id : A.fun_id) (lid : V.LoopId.id option) + (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with - | A.Regular fid -> + | TraitMethod (_, _, fid) | FunId (Regular fid) -> let info = A.FunDeclId.Map.find fid fun_infos in let stateful_group = info.stateful in let stateful = @@ -658,10 +820,10 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) can_diverge = info.can_diverge; is_rec = info.is_rec || Option.is_some lid; } - | A.Assumed aid -> + | FunId (Assumed aid) -> assert (lid = None); { - can_fail = Assumed.assumed_can_fail aid; + can_fail = Assumed.assumed_fun_can_fail aid; stateful_group = false; stateful = false; can_diverge = false; @@ -673,12 +835,14 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) Note that the function also takes a list of names for the inputs, and computes, for every output for the backward functions, a corresponding name (outputs for backward functions come from borrows in the inputs - of the forward function) which we use as hints to generate pretty names. + of the forward function) which we use as hints to generate pretty names + in the extracted code. *) -let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (fun_id : A.fun_id) (type_infos : TA.type_infos) (sg : A.fun_sig) - (input_names : string option list) (bid : T.RegionGroupId.id option) : - fun_sig_named_outputs = +let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) + (sg : A.fun_sig) (input_names : string option list) + (bid : T.RegionGroupId.id option) : fun_sig_named_outputs = + let fun_infos = decls_ctx.fun_ctx.fun_infos in + let type_infos = decls_ctx.type_ctx.type_infos in (* Retrieve the list of parent backward functions *) let gid, parents = match bid with @@ -689,7 +853,34 @@ let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) in (* Is the function stateful, and can it fail? *) let lid = None in - let effect_info = get_fun_effect_info fun_infos fun_id lid bid in + let effect_info = get_fun_effect_info fun_infos (FunId fun_id) lid bid in + (* We need an evaluation context to normalize the types (to normalize the + associated types, etc. - for instance it may happen that the types + refer to the types associated to a trait ref, but where the trait ref + is a known impl). *) + (* Create the context *) + let ctx = + let region_groups = + List.map (fun (g : T.region_var_group) -> g.id) sg.regions_hierarchy + in + let ctx = + InterpreterUtils.initialize_eval_context decls_ctx region_groups + sg.generics.types sg.generics.const_generics + in + (* Compute the normalization map for the *sty* types and add it to the context *) + AssociatedTypes.ctx_add_norm_trait_stypes_from_preds ctx + sg.preds.trait_type_constraints + in + + (* Normalize the signature *) + let sg = + let ({ A.inputs; output; _ } : A.fun_sig) = sg in + let norm = AssociatedTypes.ctx_normalize_sty ctx in + let inputs = List.map norm inputs in + let output = norm output in + { sg with A.inputs; output } + in + (* List the inputs for: * - the fuel * - the forward function @@ -806,9 +997,8 @@ let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) (* Wrap in a result type *) if effect_info.can_fail then mk_result_ty output else output in - (* Type/const generic parameters *) - let type_params = sg.type_params in - let const_generic_params = sg.const_generic_params in + (* Generic parameters *) + let generics = translate_generic_params sg.generics in (* Return *) let has_fuel = fuel <> [] in let num_fwd_inputs_no_state = List.length fwd_inputs in @@ -836,9 +1026,8 @@ let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) effect_info; } in - let sg = - { type_params; const_generic_params; inputs; output; doutputs; info } - in + let preds = translate_predicates sg.A.preds in + let sg = { generics; preds; inputs; output; doutputs; info } in { sg; output_names } let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = @@ -917,7 +1106,7 @@ let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = (** Peel boxes as long as the value is of the form [Box<T>] *) let rec unbox_typed_value (v : V.typed_value) : V.typed_value = match (v.value, v.ty) with - | V.Adt av, T.Adt (T.Assumed T.Box, _, _, _) -> ( + | V.Adt av, T.Adt (T.Assumed T.Box, _) -> ( match av.field_values with | [ bv ] -> unbox_typed_value bv | _ -> raise (Failure "Unreachable")) @@ -962,16 +1151,16 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) let field_values = List.map translate av.field_values in (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) match v.ty with - | T.Adt (T.Tuple, _, _, _) -> + | T.Adt (T.Tuple, _) -> assert (variant_id = None); mk_simpl_tuple_texpression field_values | _ -> - (* Retrieve the type, the translated type arguments and the - * const generic arguments from the translated type (simpler this way) *) - let adt_id, type_args, const_generic_args = ty_as_adt ty in + (* Retrieve the type and the translated generics from the translated + type (simpler this way) *) + let adt_id, generics = ty_as_adt ty in (* Create the constructor *) let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in - let qualif = { id = qualif_id; type_args; const_generic_args } in + let qualif = { id = qualif_id; generics } in let cons_e = Qualif qualif in let field_tys = List.map (fun (v : texpression) -> v.ty) field_values @@ -1038,11 +1227,9 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (* Translate the field values *) let field_values = List.filter_map translate adt_v.field_values in (* For now, only tuples can contain borrows *) - let adt_id, _, _, _ = TypesUtils.ty_as_adt av.ty in + let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with - | T.AdtId _ - | T.Assumed - (T.Box | T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> + | T.AdtId _ | T.Assumed (T.Box | T.Array | T.Slice | T.Str) -> assert (field_values = []); None | T.Tuple -> @@ -1185,11 +1372,9 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) (* For now, only tuples can contain borrows - note that if we gave * something like a [&mut Vec] to a function, we give back the * vector value upon visiting the "abstraction borrow" node *) - let adt_id, _, _, _ = TypesUtils.ty_as_adt av.ty in + let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with - | T.AdtId _ - | T.Assumed - (T.Box | T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> + | T.AdtId _ | T.Assumed (T.Box | T.Array | T.Slice | T.Str) -> assert (field_values = []); (ctx, None) | T.Tuple -> @@ -1457,9 +1642,12 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : texpression = + log#ldebug + (lazy + ("translate_function_call:\n" + ^ ctx_egeneric_args_to_string ctx call.generics)); (* Translate the function call *) - let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in - let const_generic_args = call.const_generic_params in + let generics = ctx_translate_fwd_generic_args ctx call.generics in let args = let args = List.map (typed_value_to_texpression ctx call.ctx) call.args in let args_mplaces = List.map translate_opt_mplace call.args_places in @@ -1475,7 +1663,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : match call.call_id with | S.Fun (fid, call_id) -> (* Regular function call *) - let func = Fun (FromLlbc (fid, None, None)) in + let fid_t = translate_fun_id_or_trait_method_ref ctx fid in + let func = Fun (FromLlbc (fid_t, None, None)) in (* Retrieve the effect information about this function (can fail, * takes a state as input, etc.) *) let effect_info = @@ -1525,18 +1714,20 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : in (ctx, Unop (Neg int_ty), effect_info, args, None) | _ -> raise (Failure "Unreachable")) - | S.Unop (E.Cast (src_ty, tgt_ty)) -> - (* Note that cast can fail *) - let effect_info = - { - can_fail = true; - stateful_group = false; - stateful = false; - can_diverge = false; - is_rec = false; - } - in - (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None) + | S.Unop (E.Cast cast_kind) -> ( + match cast_kind with + | CastInteger (src_ty, tgt_ty) -> + (* Note that cast can fail *) + let effect_info = + { + can_fail = true; + stateful_group = false; + stateful = false; + can_diverge = false; + is_rec = false; + } + in + (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None)) | S.Binop binop -> ( match args with | [ arg0; arg1 ] -> @@ -1561,7 +1752,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : | None -> dest | Some out_state -> mk_simpl_tuple_pattern [ out_state; dest ] in - let func = { id = FunOrOp fun_id; type_args; const_generic_args } in + let func = { id = FunOrOp fun_id; generics } in let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in let ret_ty = if effect_info.can_fail then mk_result_ty dest_v.ty else dest_v.ty @@ -1665,9 +1856,11 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) (* Group the two lists *) let variables_values = List.combine given_back_variables consumed_values in (* Sanity check: the two lists match (same types) *) - List.iter - (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) - variables_values; + (* TODO: normalize the types *) + if !Config.type_check_pure_code then + List.iter + (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) + variables_values; (* Translate the next expression *) let next_e = translate_expression e ctx in (* Generate the assignemnts *) @@ -1692,8 +1885,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) let effect_info = get_fun_effect_info ctx.fun_context.fun_infos fun_id None (Some rg_id) in - let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in - let const_generic_args = call.const_generic_params in + let generics = ctx_translate_fwd_generic_args ctx call.generics in (* Retrieve the original call and the parent abstractions *) let _forward, backwards = get_abs_ancestors ctx abs call_id in (* Retrieve the values consumed when we called the forward function and @@ -1741,34 +1933,35 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) | Some nstate -> mk_simpl_tuple_pattern [ nstate; output ] in (* Sanity check: there is the proper number of inputs and outputs, and they have the proper type *) - let _ = - let inst_sg = - get_instantiated_fun_sig fun_id (Some rg_id) type_args const_generic_args - ctx - in - log#ldebug - (lazy - ("\n- fun_id: " ^ A.show_fun_id fun_id ^ "\n- inputs (" - ^ string_of_int (List.length inputs) - ^ "): " - ^ String.concat ", " (List.map (texpression_to_string ctx) inputs) - ^ "\n- inst_sg.inputs (" - ^ string_of_int (List.length inst_sg.inputs) - ^ "): " - ^ String.concat ", " (List.map (ty_to_string ctx) inst_sg.inputs))); - List.iter - (fun (x, ty) -> assert ((x : texpression).ty = ty)) - (List.combine inputs inst_sg.inputs); - log#ldebug - (lazy - ("\n- outputs: " - ^ string_of_int (List.length outputs) - ^ "\n- expected outputs: " - ^ string_of_int (List.length inst_sg.doutputs))); - List.iter - (fun (x, ty) -> assert ((x : typed_pattern).ty = ty)) - (List.combine outputs inst_sg.doutputs) - in + (if (* TODO: normalize the types *) !Config.type_check_pure_code then + match fun_id with + | FunId fun_id -> + let inst_sg = + get_instantiated_fun_sig fun_id (Some rg_id) generics ctx + in + log#ldebug + (lazy + ("\n- fun_id: " ^ A.show_fun_id fun_id ^ "\n- inputs (" + ^ string_of_int (List.length inputs) + ^ "): " + ^ String.concat ", " (List.map (texpression_to_string ctx) inputs) + ^ "\n- inst_sg.inputs (" + ^ string_of_int (List.length inst_sg.inputs) + ^ "): " + ^ String.concat ", " (List.map (ty_to_string ctx) inst_sg.inputs))); + List.iter + (fun (x, ty) -> assert ((x : texpression).ty = ty)) + (List.combine inputs inst_sg.inputs); + log#ldebug + (lazy + ("\n- outputs: " + ^ string_of_int (List.length outputs) + ^ "\n- expected outputs: " + ^ string_of_int (List.length inst_sg.doutputs))); + List.iter + (fun (x, ty) -> assert ((x : typed_pattern).ty = ty)) + (List.combine outputs inst_sg.doutputs) + | _ -> (* TODO: trait methods *) ()); (* Retrieve the function id, and register the function call in the context * if necessary *) let ctx, func = @@ -1788,7 +1981,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) if effect_info.can_fail then mk_result_ty output.ty else output.ty in let func_ty = mk_arrows input_tys ret_ty in - let func = { id = FunOrOp func; type_args; const_generic_args } in + let func = { id = FunOrOp func; generics } in let func = { e = Qualif func; ty = func_ty } in let call = mk_apps func args in (* **Optimization**: @@ -1905,14 +2098,13 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (* Actually the same case as [SynthInput] *) translate_end_abstraction_synth_input ectx abs e ctx rg_id | V.LoopCall -> - let fun_id = A.Regular ctx.fun_decl.A.def_id in + let fun_id = E.Regular ctx.fun_decl.A.def_id in let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos fun_id (Some vloop_id) - (Some rg_id) + get_fun_effect_info ctx.fun_context.fun_infos (FunId fun_id) + (Some vloop_id) (Some rg_id) in let loop_info = LoopId.Map.find loop_id ctx.loops in - let type_args = loop_info.type_args in - let const_generic_args = loop_info.const_generic_args in + let generics = loop_info.generics in let fwd_inputs = Option.get loop_info.forward_inputs in (* Retrieve the additional backward inputs. Note that those are actually the backward inputs of the function we are synthesizing (and that we @@ -1960,8 +2152,8 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) if effect_info.can_fail then mk_result_ty output.ty else output.ty in let func_ty = mk_arrows input_tys ret_ty in - let func = Fun (FromLlbc (fun_id, Some loop_id, Some rg_id)) in - let func = { id = FunOrOp func; type_args; const_generic_args } in + let func = Fun (FromLlbc (FunId fun_id, Some loop_id, Some rg_id)) in + let func = { id = FunOrOp func; generics } in let func = { e = Qualif func; ty = func_ty } in let call = mk_apps func args in (* **Optimization**: @@ -2021,9 +2213,7 @@ and translate_global_eval (gid : A.GlobalDeclId.id) (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) : texpression = let ctx, var = fresh_var_for_symbolic_value sval ctx in let decl = A.GlobalDeclId.Map.find gid ctx.global_context.llbc_global_decls in - let global_expr = - { id = Global gid; type_args = []; const_generic_args = [] } - in + let global_expr = { id = Global gid; generics = empty_generic_args } in (* We use translate_fwd_ty to translate the global type *) let ty = ctx_translate_fwd_ty ctx decl.ty in let gval = { e = Qualif global_expr; ty } in @@ -2037,11 +2227,7 @@ and translate_assertion (ectx : C.eval_ctx) (v : V.typed_value) let v = typed_value_to_texpression ctx ectx v in let args = [ v ] in let func = - { - id = FunOrOp (Fun (Pure Assert)); - type_args = []; - const_generic_args = []; - } + { id = FunOrOp (Fun (Pure Assert)); generics = empty_generic_args } in let func_ty = mk_arrow (Literal Bool) mk_unit_ty in let func = { e = Qualif func; ty = func_ty } in @@ -2189,7 +2375,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (branch : S.expression) (ctx : bs_ctx) : texpression = (* TODO: always introduce a match, and use micro-passes to turn the the match into a let? *) - let type_id, _, _, _ = TypesUtils.ty_as_adt sv.V.sv_ty in + let type_id, _ = TypesUtils.ty_as_adt sv.V.sv_ty in let ctx, vars = fresh_vars_for_symbolic_values svl ctx in let branch = translate_expression branch ctx in match type_id with @@ -2224,10 +2410,10 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) * field. * We use the [dest] variable in order not to have to recompute * the type of the result of the projection... *) - let adt_id, type_args, const_generic_args = ty_as_adt scrutinee.ty in + let adt_id, generics = ty_as_adt scrutinee.ty in let gen_field_proj (field_id : FieldId.id) (dest : var) : texpression = let proj_kind = { adt_id; field_id } in - let qualif = { id = Proj proj_kind; type_args; const_generic_args } in + let qualif = { id = Proj proj_kind; generics } in let proj_e = Qualif qualif in let proj_ty = mk_arrow scrutinee.ty dest.ty in let proj = { e = proj_e; ty = proj_ty } in @@ -2259,17 +2445,12 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (mk_typed_pattern_from_var var None) (mk_opt_mplace_texpression scrutinee_mplace scrutinee) branch - | T.Assumed (T.Vec | T.Array | T.Slice | T.Str) -> + | T.Assumed (T.Array | T.Slice | T.Str) -> (* We can't expand those values: we can access the fields only * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number * of fields!) *) raise (Failure "Attempt to expand a non-expandable value") - | T.Assumed Range -> raise (Failure "Unimplemented") - | T.Assumed T.Option -> - (* We shouldn't get there in the "one-branch" case: options have - * two variants *) - raise (Failure "Unreachable") and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) (sv : V.symbolic_value) (v : S.value_aggregate) (e : S.expression) @@ -2282,8 +2463,9 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) (* Translate the next expression *) let next_e = translate_expression e ctx in - (* Translate the value: there are two cases, depending on whether this - is a "regular" let-binding or an array aggregate. + (* Translate the value: there are several cases, depending on whether this + is a "regular" let-binding, an array aggregate, a const generic or + a trait associated constant. *) let v = match v with @@ -2298,6 +2480,14 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) { struct_id = Assumed Array; init = None; updates = values } in { e = StructUpdate su; ty = var.ty } + | ConstGenericValue cg_id -> { e = CVar cg_id; ty = var.ty } + | TraitConstValue (trait_ref, generics, const_name) -> + let type_infos = ctx.type_context.type_infos in + let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + let generics = translate_fwd_generic_args type_infos generics in + let qualif_id = TraitConst (trait_ref, generics, const_name) in + let qualif = { id = qualif_id; generics = empty_generic_args } in + { e = Qualif qualif; ty = var.ty } in (* Make the let-binding *) @@ -2368,9 +2558,9 @@ and translate_forward_end (ectx : C.eval_ctx) let org_args = args in (* Lookup the effect info for the loop function *) - let fid = A.Regular ctx.fun_decl.A.def_id in + let fid = E.Regular ctx.fun_decl.A.def_id in let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos fid None ctx.bid + get_fun_effect_info ctx.fun_context.fun_infos (FunId fid) None ctx.bid in (* Introduce a fresh output value for the forward function *) @@ -2415,14 +2605,8 @@ and translate_forward_end (ectx : C.eval_ctx) let out_pat = mk_simpl_tuple_pattern out_pats in let loop_call = - let fun_id = Fun (FromLlbc (fid, Some loop_id, None)) in - let func = - { - id = FunOrOp fun_id; - type_args = loop_info.type_args; - const_generic_args = loop_info.const_generic_args; - } - in + let fun_id = Fun (FromLlbc (FunId fid, Some loop_id, None)) in + let func = { id = FunOrOp fun_id; generics = loop_info.generics } in let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in let ret_ty = if effect_info.can_fail then mk_result_ty out_pat.ty else out_pat.ty @@ -2541,14 +2725,31 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* Note that we will retrieve the input values later in the [ForwardEnd] (and will introduce the outputs at that moment, together with the actual - call to the loop forward function *) - let type_args = - List.map (fun (ty : T.type_var) -> TypeVar ty.T.index) ctx.sg.type_params - in - let const_generic_args = - List.map - (fun (cg : T.const_generic_var) -> T.ConstGenericVar cg.T.index) - ctx.sg.const_generic_params + call to the loop forward function) *) + let generics = + let { types; const_generics; trait_clauses } = ctx.sg.generics in + let types = + List.map (fun (ty : T.type_var) -> TypeVar ty.T.index) types + in + let const_generics = + List.map + (fun (cg : T.const_generic_var) -> T.ConstGenericVar cg.T.index) + const_generics + in + let trait_refs = + List.map + (fun (c : trait_clause) -> + let trait_decl_ref = + { trait_decl_id = c.trait_id; decl_generics = empty_generic_args } + in + { + trait_id = Clause c.clause_id; + generics = empty_generic_args; + trait_decl_ref; + }) + trait_clauses + in + { types; const_generics; trait_refs } in let loop_info = @@ -2556,8 +2757,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = loop_id; input_vars = inputs; input_svl = loop.input_svalues; - type_args; - const_generic_args; + generics; forward_inputs = None; forward_output_no_state_no_result = None; } @@ -2648,8 +2848,7 @@ let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) let func = { id = FunOrOp (Fun (Pure FuelEqZero)); - type_args = []; - const_generic_args = []; + generics = empty_generic_args; } in let func_ty = mk_arrow mk_fuel_ty mk_bool_ty in @@ -2661,8 +2860,7 @@ let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) let func = { id = FunOrOp (Fun (Pure FuelDecrease)); - type_args = []; - const_generic_args = []; + generics = empty_generic_args; } in let func_ty = mk_arrow mk_fuel_ty mk_fuel_ty in @@ -2727,8 +2925,8 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = | None -> None | Some body -> let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos (Regular def_id) None - bid + get_fun_effect_info ctx.fun_context.fun_infos (FunId (Regular def_id)) + None bid in let body = translate_expression body ctx in (* Add a match over the fuel, if necessary *) @@ -2803,10 +3001,12 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = ^ "\n- signature.inputs: " ^ String.concat ", " (List.map (ty_to_string ctx) signature.inputs) )); - assert ( - List.for_all - (fun (var, ty) -> (var : var).ty = ty) - (List.combine inputs signature.inputs)); + (* TODO: we need to normalize the types *) + if !Config.type_check_pure_code then + assert ( + List.for_all + (fun (var, ty) -> (var : var).ty = ty) + (List.combine inputs signature.inputs)); Some { inputs; inputs_lvs; body } in @@ -2821,6 +3021,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = let def = { def_id; + kind = def.kind; num_loops; loop_id; back_id = bid; @@ -2853,8 +3054,7 @@ let translate_type_decls (type_decls : T.type_decl list) : type_decl list = - optional names for the outputs values (we derive them for the backward functions) *) -let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (type_infos : TA.type_infos) +let translate_fun_signatures (decls_ctx : C.decls_ctx) (functions : (A.fun_id * string option list * A.fun_sig) list) : fun_sig_named_outputs RegularFunIdNotLoopMap.t = (* For every function, translate the signatures of: @@ -2865,17 +3065,14 @@ let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) (sg : A.fun_sig) : (regular_fun_id_not_loop * fun_sig_named_outputs) list = (* The forward function *) - let fwd_sg = - translate_fun_sig fun_infos fun_id type_infos sg input_names None - in + let fwd_sg = translate_fun_sig decls_ctx fun_id sg input_names None in let fwd_id = (fun_id, None) in (* The backward functions *) let back_sgs = List.map (fun (rg : T.region_var_group) -> let tsg = - translate_fun_sig fun_infos fun_id type_infos sg input_names - (Some rg.id) + translate_fun_sig decls_ctx fun_id sg input_names (Some rg.id) in let id = (fun_id, Some rg.id) in (id, tsg)) @@ -2891,3 +3088,94 @@ let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) List.fold_left (fun m (id, sg) -> RegularFunIdNotLoopMap.add id sg m) RegularFunIdNotLoopMap.empty translated + +let translate_trait_decl (type_infos : TA.type_infos) + (trait_decl : A.trait_decl) : trait_decl = + let { + def_id; + name; + generics; + preds; + parent_clauses; + consts; + types; + required_methods; + provided_methods; + } : A.trait_decl = + trait_decl + in + let generics = translate_generic_params generics in + let preds = translate_predicates preds in + let parent_clauses = List.map translate_trait_clause parent_clauses in + let consts = + List.map + (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) + consts + in + let types = + List.map + (fun (name, (trait_clauses, ty)) -> + ( name, + ( List.map translate_trait_clause trait_clauses, + Option.map (translate_fwd_ty type_infos) ty ) )) + types + in + { + def_id; + name; + generics; + preds; + parent_clauses; + consts; + types; + required_methods; + provided_methods; + } + +let translate_trait_impl (type_infos : TA.type_infos) + (trait_impl : A.trait_impl) : trait_impl = + let { + A.def_id; + name; + impl_trait; + generics; + preds; + parent_trait_refs; + consts; + types; + required_methods; + provided_methods; + } = + trait_impl + in + let impl_trait = + translate_trait_decl_ref (translate_fwd_ty type_infos) impl_trait + in + let generics = translate_generic_params generics in + let preds = translate_predicates preds in + let parent_trait_refs = List.map translate_strait_ref parent_trait_refs in + let consts = + List.map + (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) + consts + in + let types = + List.map + (fun (name, (trait_refs, ty)) -> + ( name, + ( List.map (translate_fwd_trait_ref type_infos) trait_refs, + translate_fwd_ty type_infos ty ) )) + types + in + { + def_id; + name; + impl_trait; + generics; + preds; + parent_trait_refs; + consts; + types; + required_methods; + provided_methods; + } diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 857fea97..9dd65c84 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -64,7 +64,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) assert (otherwise_see = None); (* Return *) ExpandInt (int_ty, branches, otherwise) - | T.Adt (_, _, _, _) -> + | T.Adt (_, _) -> (* Branching: it is necessarily an enumeration expansion *) let get_variant (see : V.symbolic_expansion option) : T.VariantId.id option * V.symbolic_value list = @@ -85,7 +85,9 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) - | T.TypeVar _ | T.Literal Char | Never -> + | T.TypeVar _ + | T.Literal Char + | Never | T.TraitType _ | T.Arrow _ | T.RawPtr _ -> raise (Failure "Ill-formed symbolic expansion") in Some (Expansion (place, sv, expansion)) @@ -97,10 +99,10 @@ let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) synthesize_symbolic_expansion sv place [ Some see ] el let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (type_params : T.ety list) - (const_generic_params : T.const_generic list) (args : V.typed_value list) - (args_places : mplace option list) (dest : V.symbolic_value) - (dest_place : mplace option) (e : expression option) : expression option = + (abstractions : V.AbstractionId.id list) (generics : T.egeneric_args) + (args : V.typed_value list) (args_places : mplace option list) + (dest : V.symbolic_value) (dest_place : mplace option) + (e : expression option) : expression option = Option.map (fun e -> let call = @@ -108,8 +110,7 @@ let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) call_id; ctx; abstractions; - type_params; - const_generic_params; + generics; args; dest; args_places; @@ -123,28 +124,29 @@ let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) (e : expression option) : expression option = Option.map (fun e -> EvalGlobal (gid, dest, e)) e -let synthesize_regular_function_call (fun_id : A.fun_id) +let synthesize_regular_function_call (fun_id : A.fun_id_or_trait_method_ref) (call_id : V.FunCallId.id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (type_params : T.ety list) - (const_generic_params : T.const_generic list) (args : V.typed_value list) - (args_places : mplace option list) (dest : V.symbolic_value) - (dest_place : mplace option) (e : expression option) : expression option = + (abstractions : V.AbstractionId.id list) (generics : T.egeneric_args) + (args : V.typed_value list) (args_places : mplace option list) + (dest : V.symbolic_value) (dest_place : mplace option) + (e : expression option) : expression option = synthesize_function_call (Fun (fun_id, call_id)) - ctx abstractions type_params const_generic_params args args_places dest - dest_place e + ctx abstractions generics args args_places dest dest_place e let synthesize_unary_op (ctx : Contexts.eval_ctx) (unop : E.unop) (arg : V.typed_value) (arg_place : mplace option) (dest : V.symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = - synthesize_function_call (Unop unop) ctx [] [] [] [ arg ] [ arg_place ] dest - dest_place e + let generics = TypesUtils.mk_empty_generic_args in + synthesize_function_call (Unop unop) ctx [] generics [ arg ] [ arg_place ] + dest dest_place e let synthesize_binary_op (ctx : Contexts.eval_ctx) (binop : E.binop) (arg0 : V.typed_value) (arg0_place : mplace option) (arg1 : V.typed_value) (arg1_place : mplace option) (dest : V.symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = - synthesize_function_call (Binop binop) ctx [] [] [] [ arg0; arg1 ] + let generics = TypesUtils.mk_empty_generic_args in + synthesize_function_call (Binop binop) ctx [] generics [ arg0; arg1 ] [ arg0_place; arg1_place ] dest dest_place e let synthesize_end_abstraction (ctx : Contexts.eval_ctx) (abs : V.abs) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 70ef5e3d..a3d96023 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -5,6 +5,7 @@ module T = Types module A = LlbcAst module SA = SymbolicAst module Micro = PureMicroPasses +module C = Contexts open PureUtils open TranslateCore @@ -28,18 +29,12 @@ let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : A.fun_decl) ("translate_function_to_symbolics: " ^ Print.fun_name_to_string fdef.A.name)); - let { type_context; fun_context; global_context } = trans_ctx in - let fun_context = { C.fun_decls = fun_context.fun_decls } in - match fdef.body with | None -> None | Some _ -> (* Evaluate *) let synthesize = true in - let inputs, symb = - evaluate_function_symbolic synthesize type_context fun_context - global_context fdef - in + let inputs, symb = evaluate_function_symbolic synthesize trans_ctx fdef in Some (inputs, Option.get symb) (** Translate a function, by generating its forward and backward translations. @@ -57,7 +52,6 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (lazy ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); - let { type_context; fun_context; global_context } = trans_ctx in let def_id = fdef.def_id in (* Compute the symbolic ASTs, if the function is transparent *) @@ -67,7 +61,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context *) let forward_sig = - RegularFunIdNotLoopMap.find (A.Regular def_id, None) fun_sigs + RegularFunIdNotLoopMap.find (E.Regular def_id, None) fun_sigs in let sv_to_var = V.SymbolicValueId.Map.empty in let var_counter = Pure.VarId.generator_zero in @@ -82,25 +76,25 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (List.filter_map (fun (tid, g) -> match g with Charon.GAst.NonRec _ -> None | Rec _ -> Some tid) - (T.TypeDeclId.Map.bindings trans_ctx.type_context.type_decls_groups)) + (T.TypeDeclId.Map.bindings trans_ctx.type_ctx.type_decls_groups)) in let type_context = { - SymbolicToPure.type_infos = type_context.type_infos; - llbc_type_decls = type_context.type_decls; + SymbolicToPure.type_infos = trans_ctx.type_ctx.type_infos; + llbc_type_decls = trans_ctx.type_ctx.type_decls; type_decls = pure_type_decls; recursive_decls = recursive_type_decls; } in let fun_context = { - SymbolicToPure.llbc_fun_decls = fun_context.fun_decls; + SymbolicToPure.llbc_fun_decls = trans_ctx.fun_ctx.fun_decls; fun_sigs; - fun_infos = fun_context.fun_infos; + fun_infos = trans_ctx.fun_ctx.fun_infos; } in let global_context = - { SymbolicToPure.llbc_global_decls = global_context.global_decls } + { SymbolicToPure.llbc_global_decls = trans_ctx.global_ctx.global_decls } in (* Compute the set of loops, and find better ids for them (starting at 0). @@ -148,6 +142,8 @@ let translate_function_to_pure (trans_ctx : trans_ctx) type_context; fun_context; global_context; + trait_decls_ctx = trans_ctx.trait_decls_ctx.trait_decls; + trait_impls_ctx = trans_ctx.trait_impls_ctx.trait_impls; fun_decl = fdef; forward_inputs = []; (* Empty for now *) @@ -204,7 +200,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context - note that the ret_ty is not really * useful as we don't translate a body *) let backward_sg = - RegularFunIdNotLoopMap.find (A.Regular def_id, Some back_id) fun_sigs + RegularFunIdNotLoopMap.find (Regular def_id, Some back_id) fun_sigs in let ctx = { ctx with bid = Some back_id; sg = backward_sg.sg } in @@ -215,7 +211,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) variables required by the backward function. *) let backward_sg = - RegularFunIdNotLoopMap.find (A.Regular def_id, Some back_id) fun_sigs + RegularFunIdNotLoopMap.find (Regular def_id, Some back_id) fun_sigs in (* We need to ignore the forward inputs, and the state input (if there is) *) let backward_inputs = @@ -274,21 +270,18 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Return *) (pure_forward, pure_backwards) +(* TODO: factor out the return type *) let translate_crate_to_pure (crate : A.crate) : - trans_ctx * Pure.type_decl list * (bool * pure_fun_translation) list = + trans_ctx + * Pure.type_decl list + * pure_fun_translation list + * Pure.trait_decl list + * Pure.trait_impl list = (* Debug *) log#ldebug (lazy "translate_crate_to_pure"); - (* Compute the type and function contexts *) - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let fun_infos = - FA.analyze_module crate fun_context.C.fun_decls - global_context.C.global_decls !Config.use_state - in - let fun_context = { fun_decls = fun_context.fun_decls; fun_infos } in - let trans_ctx = { type_context; fun_context; global_context } in + (* Compute the translation context *) + let trans_ctx = compute_contexts crate in (* Translate all the type definitions *) let type_decls = @@ -304,9 +297,11 @@ let translate_crate_to_pure (crate : A.crate) : (* Translate all the function *signatures* *) let assumed_sigs = List.map - (fun (id, sg, _, _) -> - (A.Assumed id, List.map (fun _ -> None) (sg : A.fun_sig).inputs, sg)) - Assumed.assumed_infos + (fun (info : Assumed.assumed_fun_info) -> + ( E.Assumed info.fun_id, + List.map (fun _ -> None) info.fun_sig.inputs, + info.fun_sig )) + Assumed.assumed_fun_infos in let local_sigs = List.map @@ -319,14 +314,11 @@ let translate_crate_to_pure (crate : A.crate) : (fun (v : A.var) -> v.name) (LlbcAstUtils.fun_body_get_input_vars body) in - (A.Regular fdef.def_id, input_names, fdef.signature)) + (E.Regular fdef.def_id, input_names, fdef.signature)) (A.FunDeclId.Map.values crate.functions) in let sigs = List.append assumed_sigs local_sigs in - let fun_sigs = - SymbolicToPure.translate_fun_signatures fun_context.fun_infos - type_context.type_infos sigs - in + let fun_sigs = SymbolicToPure.translate_fun_signatures trans_ctx sigs in (* Translate all the *transparent* functions *) let pure_translations = @@ -335,28 +327,38 @@ let translate_crate_to_pure (crate : A.crate) : (A.FunDeclId.Map.values crate.functions) in + (* Translate the trait declarations *) + let type_infos = trans_ctx.type_ctx.type_infos in + let trait_decls = + List.map + (SymbolicToPure.translate_trait_decl type_infos) + (T.TraitDeclId.Map.values trans_ctx.trait_decls_ctx.trait_decls) + in + + (* Translate the trait implementations *) + let trait_impls = + List.map + (SymbolicToPure.translate_trait_impl type_infos) + (T.TraitImplId.Map.values trans_ctx.trait_impls_ctx.trait_impls) + in + (* Apply the micro-passes *) let pure_translations = Micro.apply_passes_to_pure_fun_translations trans_ctx pure_translations in (* Return *) - (trans_ctx, type_decls, pure_translations) - -(** Extraction context *) -type gen_ctx = { - crate : A.crate; - extract_ctx : ExtractBase.extraction_ctx; - trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; - trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; - functions_with_decreases_clause : PureUtils.FunLoopIdSet.t; -} + (trans_ctx, type_decls, pure_translations, trait_decls, trait_impls) + +type gen_ctx = ExtractBase.extraction_ctx type gen_config = { extract_types : bool; extract_decreases_clauses : bool; extract_template_decreases_clauses : bool; extract_fun_decls : bool; + extract_trait_decls : bool; + extract_trait_impls : bool; extract_transparent : bool; (** If [true], extract the transparent declarations, otherwise ignore. *) extract_opaque : bool; @@ -383,21 +385,23 @@ type gen_config = { test_trans_unit_functions : bool; } -(** Returns the pair: (has opaque type decls, has opaque fun decls) *) -let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = - let has_opaque_types = - Pure.TypeDeclId.Map.exists - (fun _ (d : Pure.type_decl) -> - match d.kind with Opaque -> true | _ -> false) - ctx.trans_types - in - let has_opaque_funs = - A.FunDeclId.Map.exists - (fun _ ((_, ((t_fwd, _), _)) : bool * pure_fun_translation) -> - Option.is_none t_fwd.body) - ctx.trans_funs +(** Returns the pair: (has opaque type decls, has opaque fun decls). + + [filter_assumed]: if [true], do not consider as opaque the external definitions + that we will map to definitions from the standard library. + *) +let crate_has_opaque_non_builtin_decls (ctx : gen_ctx) (filter_assumed : bool) : + bool * bool = + let types, funs = + LlbcAstUtils.crate_get_opaque_non_builtin_decls ctx.crate filter_assumed in - (has_opaque_types, has_opaque_funs) + log#ldebug + (lazy + ("Opaque decls:" ^ "\n- types:\n" + ^ String.concat ",\n" (List.map T.show_type_decl types) + ^ "\n- functions:\n" + ^ String.concat ",\n" (List.map A.show_fun_decl funs))); + (types <> [], funs <> []) (** Export a type declaration. @@ -423,15 +427,19 @@ let export_type (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (true, kind) in (* Extract, if the config instructs to do so (depending on whether the type - * is opaque or not) *) - if + is opaque or not). Remark: we don't check if the definitions are builtin + here but in the function [export_types_group]: the reason is that if one + definition in the group is builtin, then we must check that all the + definitions are marked builtin *) + let extract = (is_opaque && config.extract_opaque) || ((not is_opaque) && config.extract_transparent) - then ( + in + if extract then ( if extract_decl then - Extract.extract_type_decl ctx.extract_ctx fmt type_decl_group kind def; + Extract.extract_type_decl ctx fmt type_decl_group kind def; if extract_extra_info then - Extract.extract_type_decl_extra_info ctx.extract_ctx fmt kind def) + Extract.extract_type_decl_extra_info ctx fmt kind def) (** Export a group of types. @@ -462,41 +470,58 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) List.map (fun id -> Pure.TypeDeclId.Map.find id ctx.trans_types) ids in - (* Extract the type declarations. - - Because some declaration groups are delimited, we wrap the declarations - between [{start,end}_type_decl_group]. + (* Check if the definition are builtin - if yes they must be ignored. + Note that if one definition in the group is builtin, then all the + definitions must be builtin *) + let builtin = + let open ExtractBuiltin in + let types_map = builtin_types_map () in + List.map + (fun (def : Pure.type_decl) -> + let sname = name_to_simple_name def.name in + SimpleNameMap.find_opt sname types_map <> None) + defs + in - Ex.: - ==== - When targeting HOL4, the calls to [{start,end}_type_decl_group] would generate - the [Datatype] and [End] delimiters in the snippet of code below: + if List.exists (fun b -> b) builtin then + (* Sanity check *) + assert (List.for_all (fun b -> b) builtin) + else ( + (* Extract the type declarations. + + Because some declaration groups are delimited, we wrap the declarations + between [{start,end}_type_decl_group]. + + Ex.: + ==== + When targeting HOL4, the calls to [{start,end}_type_decl_group] would generate + the [Datatype] and [End] delimiters in the snippet of code below: + + {[ + Datatype: + tree = + TLeaf 'a + | TNode node ; + + node = + Node (tree list) + End + ]} + *) + Extract.start_type_decl_group ctx fmt is_rec defs; + List.iteri + (fun i def -> + let kind = kind_from_index i in + export_type_decl kind def) + defs; + Extract.end_type_decl_group fmt is_rec defs; - {[ - Datatype: - tree = - TLeaf 'a - | TNode node ; - - node = - Node (tree list) - End - ]} - *) - Extract.start_type_decl_group ctx.extract_ctx fmt is_rec defs; - List.iteri - (fun i def -> - let kind = kind_from_index i in - export_type_decl kind def) - defs; - Extract.end_type_decl_group fmt is_rec defs; - - (* Export the extra information (ex.: [Arguments] instructions in Coq) *) - List.iteri - (fun i def -> - let kind = kind_from_index i in - export_type_extra_info kind def) - defs + (* Export the extra information (ex.: [Arguments] instructions in Coq) *) + List.iteri + (fun i def -> + let kind = kind_from_index i in + export_type_extra_info kind def) + defs) (** Export a global declaration. @@ -504,26 +529,34 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) *) let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (id : A.GlobalDeclId.id) : unit = - let global_decls = ctx.extract_ctx.trans_ctx.global_context.global_decls in + let global_decls = ctx.trans_ctx.global_ctx.global_decls in let global = A.GlobalDeclId.Map.find id global_decls in - let _, ((body, loop_fwds), body_backs) = - A.FunDeclId.Map.find global.body_id ctx.trans_funs - in - assert (body_backs = []); - assert (loop_fwds = []); + let trans = A.FunDeclId.Map.find global.body_id ctx.trans_funs in + assert (trans.fwd.loops = []); + assert (trans.backs = []); + let body = trans.fwd.f in let is_opaque = Option.is_none body.Pure.body in - if + (* Check if we extract the global *) + let extract = config.extract_globals && (((not is_opaque) && config.extract_transparent) || (is_opaque && config.extract_opaque)) - then + in + (* Check if it is a builtin global - if yes, we ignore it because we + map the definition to one in the standard library *) + let open ExtractBuiltin in + let sname = name_to_simple_name global.name in + let extract = + extract && SimpleNameMap.find_opt sname builtin_globals_map = None + in + if extract then (* We don't wrap global declaration groups between calls to functions [{start, end}_global_decl_group] (which don't exist): global declaration groups are always singletons, so the [extract_global_decl] function takes care of generating the delimiters. *) - Extract.extract_global_decl ctx.extract_ctx fmt global body config.interface + Extract.extract_global_decl ctx fmt global body config.interface (** Utility. @@ -604,14 +637,13 @@ let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) then Some (fun () -> - Extract.extract_fun_decl ctx.extract_ctx fmt kind has_decr_clause - def) + Extract.extract_fun_decl ctx fmt kind has_decr_clause def) else None) decls in let extract_defs = List.filter_map (fun x -> x) extract_defs in if extract_defs <> [] then ( - Extract.start_fun_decl_group ctx.extract_ctx fmt is_rec decls; + Extract.start_fun_decl_group ctx fmt is_rec decls; List.iter (fun f -> f ()) extract_defs; Extract.end_fun_decl_group fmt is_rec decls) @@ -621,82 +653,137 @@ let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) check if the forward and backward functions are mutually recursive. *) let export_functions_group (fmt : Format.formatter) (config : gen_config) - (ctx : gen_ctx) (pure_ls : (bool * pure_fun_translation) list) : unit = - (* Utility to check a function has a decrease clause *) - let has_decreases_clause (def : Pure.fun_decl) : bool = - PureUtils.FunLoopIdSet.mem (def.def_id, def.loop_id) - ctx.functions_with_decreases_clause + (ctx : gen_ctx) (pure_ls : pure_fun_translation list) : unit = + (* Check if the definition are builtin - if yes they must be ignored. + Note that if one definition in the group is builtin, then all the + definitions must be builtin *) + let builtin = + let open ExtractBuiltin in + let funs_map = builtin_funs_map () in + List.map + (fun (trans : pure_fun_translation) -> + let sname = name_to_simple_name trans.fwd.f.basename in + SimpleNameMap.find_opt sname funs_map <> None) + pure_ls in - (* Extract the decrease clauses template bodies *) - if config.extract_template_decreases_clauses then - List.iter - (fun (_, ((fwd, loop_fwds), _)) -> - (* We only generate decreases clauses for the forward functions, because - the termination argument should only depend on the forward inputs. - The backward functions thus use the same decreases clauses as the - forward function. - - Rem.: we might filter backward functions in {!PureMicroPasses}, but - we don't remove forward functions. Instead, we remember if we should - filter those functions at extraction time with a boolean (see the - type of the [pure_ls] input parameter). - *) - let extract_decrease decl = - let has_decr_clause = has_decreases_clause decl in - if has_decr_clause then - match !Config.backend with - | Lean -> - Extract.extract_template_lean_termination_and_decreasing - ctx.extract_ctx fmt decl - | FStar -> - Extract.extract_template_fstar_decreases_clause ctx.extract_ctx - fmt decl - | Coq -> - raise (Failure "Coq doesn't have decreases/termination clauses") - | HOL4 -> - raise - (Failure "HOL4 doesn't have decreases/termination clauses") - in - extract_decrease fwd; - List.iter extract_decrease loop_fwds) - pure_ls; - - (* Concatenate the function definitions, filtering the useless forward - * functions. *) - let decls = - List.concat - (List.map - (fun (keep_fwd, ((fwd, fwd_loops), (back_ls : fun_and_loops list))) -> - let fwd = if keep_fwd then List.append fwd_loops [ fwd ] else [] in - let back : Pure.fun_decl list = - List.concat - (List.map - (fun (back, loop_backs) -> List.append loop_backs [ back ]) - back_ls) - in - List.append fwd back) - pure_ls) - in + if List.exists (fun b -> b) builtin then + (* Sanity check *) + assert (List.for_all (fun b -> b) builtin) + else + (* Utility to check a function has a decrease clause *) + let has_decreases_clause (def : Pure.fun_decl) : bool = + PureUtils.FunLoopIdSet.mem (def.def_id, def.loop_id) + ctx.functions_with_decreases_clause + in - (* Extract the function definitions *) - (if config.extract_fun_decls then - (* Group the mutually recursive definitions *) - let subgroups = ReorderDecls.group_reorder_fun_decls decls in + (* Extract the decrease clauses template bodies *) + if config.extract_template_decreases_clauses then + List.iter + (fun { fwd; _ } -> + (* We only generate decreases clauses for the forward functions, because + the termination argument should only depend on the forward inputs. + The backward functions thus use the same decreases clauses as the + forward function. + + Rem.: we might filter backward functions in {!PureMicroPasses}, but + we don't remove forward functions. Instead, we remember if we should + filter those functions at extraction time with a boolean (see the + type of the [pure_ls] input parameter). + *) + let extract_decrease decl = + let has_decr_clause = has_decreases_clause decl in + if has_decr_clause then + match !Config.backend with + | Lean -> + Extract.extract_template_lean_termination_and_decreasing ctx + fmt decl + | FStar -> + Extract.extract_template_fstar_decreases_clause ctx fmt decl + | Coq -> + raise + (Failure "Coq doesn't have decreases/termination clauses") + | HOL4 -> + raise + (Failure "HOL4 doesn't have decreases/termination clauses") + in + extract_decrease fwd.f; + List.iter extract_decrease fwd.loops) + pure_ls; + + (* Concatenate the function definitions, filtering the useless forward + * functions. *) + let decls = + List.concat + (List.map + (fun { keep_fwd; fwd; backs } -> + let fwd = + if keep_fwd then List.append fwd.loops [ fwd.f ] else [] + in + let backs : Pure.fun_decl list = + List.concat + (List.map + (fun back -> List.append back.loops [ back.f ]) + backs) + in + List.append fwd backs) + pure_ls) + in - (* Extract the subgroups *) - let export_subgroup (is_rec : bool) (decls : Pure.fun_decl list) : unit = - export_functions_group_scc fmt config ctx is_rec decls - in - List.iter (fun (is_rec, decls) -> export_subgroup is_rec decls) subgroups); - - (* Insert unit tests if necessary *) - if config.test_trans_unit_functions then - List.iter - (fun (keep_fwd, ((fwd, _), _)) -> - if keep_fwd then - Extract.extract_unit_test_if_unit_fun ctx.extract_ctx fmt fwd) - pure_ls + (* Extract the function definitions *) + (if config.extract_fun_decls then + (* Group the mutually recursive definitions *) + let subgroups = ReorderDecls.group_reorder_fun_decls decls in + + (* Extract the subgroups *) + let export_subgroup (is_rec : bool) (decls : Pure.fun_decl list) : unit = + export_functions_group_scc fmt config ctx is_rec decls + in + List.iter (fun (is_rec, decls) -> export_subgroup is_rec decls) subgroups); + + (* Insert unit tests if necessary *) + if config.test_trans_unit_functions then + List.iter + (fun trans -> + if trans.keep_fwd then + Extract.extract_unit_test_if_unit_fun ctx fmt trans.fwd.f) + pure_ls + +(** Export a trait declaration. *) +let export_trait_decl (fmt : Format.formatter) (_config : gen_config) + (ctx : gen_ctx) (trait_decl_id : Pure.trait_decl_id) (extract_decl : bool) + (extract_extra_info : bool) : unit = + let trait_decl = T.TraitDeclId.Map.find trait_decl_id ctx.trans_trait_decls in + (* Check if the trait declaration is builtin, in which case we ignore it *) + let open ExtractBuiltin in + let sname = name_to_simple_name trait_decl.name in + if SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) = None then ( + let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in + if extract_decl then Extract.extract_trait_decl ctx fmt trait_decl; + if extract_extra_info then + Extract.extract_trait_decl_extra_info ctx fmt trait_decl) + else () + +(** Export a trait implementation. *) +let export_trait_impl (fmt : Format.formatter) (_config : gen_config) + (ctx : gen_ctx) (trait_impl_id : Pure.trait_impl_id) : unit = + (* Lookup the definition *) + let trait_impl = T.TraitImplId.Map.find trait_impl_id ctx.trans_trait_impls in + let trait_decl = + Pure.TraitDeclId.Map.find trait_impl.impl_trait.trait_decl_id + ctx.trans_trait_decls + in + (* Check if the trait implementation is builtin *) + let builtin_info = + let open ExtractBuiltin in + let type_sname = name_to_simple_name trait_impl.name in + let trait_sname = name_to_simple_name trait_decl.name in + SimpleNamePairMap.find_opt (type_sname, trait_sname) + (builtin_trait_impls_map ()) + in + match builtin_info with + | None -> Extract.extract_trait_impl ctx fmt trait_impl + | Some _ -> () (** A generic utility to generate the extracted definitions: as we may want to split the definitions between different files (or not), we can control @@ -712,12 +799,19 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) let export_functions_group = export_functions_group fmt config ctx in let export_global = export_global fmt config ctx in let export_types_group = export_types_group fmt config ctx in + let export_trait_decl_group id = + export_trait_decl fmt config ctx id true false + in + let export_trait_decl_group_extra_info id = + export_trait_decl fmt config ctx id false true + in + let export_trait_impl = export_trait_impl fmt config ctx in let export_state_type () : unit = let kind = if config.interface then ExtractBase.Declared else ExtractBase.Assumed in - Extract.extract_state_type fmt ctx.extract_ctx kind + Extract.extract_state_type fmt ctx kind in let export_decl_group (dg : A.declaration_group) : unit = @@ -725,11 +819,18 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) | Type (NonRec id) -> if config.extract_types then export_types_group false [ id ] | Type (Rec ids) -> if config.extract_types then export_types_group true ids - | Fun (NonRec id) -> + | Fun (NonRec id) -> ( (* Lookup *) let pure_fun = A.FunDeclId.Map.find id ctx.trans_funs in - (* Translate *) - export_functions_group [ pure_fun ] + (* Special case: we skip trait method *declarations* (we will + extract their type directly in the records we generate for + the trait declarations themselves, there is no point in having + separate type definitions) *) + match pure_fun.fwd.f.Pure.kind with + | TraitMethodDecl _ -> () + | _ -> + (* Translate *) + export_functions_group [ pure_fun ]) | Fun (Rec ids) -> (* General case of mutually recursive functions *) (* Lookup *) @@ -739,11 +840,19 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) (* Translate *) export_functions_group pure_funs | Global id -> export_global id + | TraitDecl id -> + (* TODO: update to extract groups *) + if config.extract_trait_decls && config.extract_transparent then ( + export_trait_decl_group id; + export_trait_decl_group_extra_info id) + | TraitImpl id -> + if config.extract_trait_impls && config.extract_transparent then + export_trait_impl id in (* If we need to export the state type: we try to export it after we defined * the type definitions, because if the user wants to define a model for the - * type, he might want to reuse those in the state type. + * type, they might want to reuse those in the state type. * More specifically: if we extract functions in the same file as the type, * we have no choice but to define the state type before the functions, * because they may reuse this state type: in this case, we define/declare @@ -752,37 +861,10 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) if config.extract_state_type && config.extract_fun_decls then export_state_type (); - (* Obsolete: (TODO: remove) For Lean we parameterize the entire development by a section - variable called opaque_defs, of type OpaqueDefs. The code below emits the type - definition for OpaqueDefs, which is a structure, in which each field is one of the - functions marked as Opaque. We emit the `structure ...` bit here, then rely on - `extract_fun_decl` to be aware of this, and skip the keyword (e.g. "axiom" or "val") - so as to generate valid syntax for records. - - We also generate such a structure only if there actually are opaque definitions. *) - let wrap_in_sig = - config.extract_opaque && config.extract_fun_decls - && !Config.wrap_opaque_in_sig - && - let _, opaque_funs = module_has_opaque_decls ctx in - opaque_funs - in - if wrap_in_sig then ( - (* We change the name of the structure depending on whether we *only* - extract opaque definitions, or if we extract all definitions *) - let struct_name = - if config.extract_transparent then "Definitions" else "OpaqueDefs" - in - Format.pp_print_break fmt 0 0; - Format.pp_open_vbox fmt ctx.extract_ctx.indent_incr; - Format.pp_print_string fmt ("structure " ^ struct_name ^ " where"); - Format.pp_print_break fmt 0 0); List.iter export_decl_group ctx.crate.declarations; if config.extract_state_type && not config.extract_fun_decls then - export_state_type (); - - if wrap_in_sig then Format.pp_close_box fmt () + export_state_type () type extract_file_info = { filename : string; @@ -904,7 +986,9 @@ let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : unit = (* Translate the module to the pure AST *) - let trans_ctx, trans_types, trans_funs = translate_crate_to_pure crate in + let trans_ctx, trans_types, trans_funs, trans_trait_decls, trans_trait_impls = + translate_crate_to_pure crate + in (* Initialize the extraction context - for now we extract only to F*. * We initialize the names map by registering the keywords used in the @@ -916,41 +1000,27 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : in (* Initialize the names map (we insert the names of the "primitives" declarations, and insert the names of the local declarations later) *) - let mk_formatter_and_names_map = Extract.mk_formatter_and_names_map in - let fmt, names_map = - mk_formatter_and_names_map trans_ctx crate.name + let fmt, names_maps = + Extract.mk_formatter_and_names_maps trans_ctx crate.name variant_concatenate_type_name in - (* Put everything in the context *) - let ctx = - { - ExtractBase.trans_ctx; - names_map; - unsafe_names_map = { id_to_name = ExtractBase.IdMap.empty }; - fmt; - indent_incr = 2; - use_opaque_pre = !Config.split_files; - use_dep_ite = !Config.backend = Lean && !Config.extract_decreases_clauses; - fun_name_info = PureUtils.RegularFunIdMap.empty; - } - in (* We need to compute which functions are recursive, in order to know * whether we should generate a decrease clause or not. *) let rec_functions = List.map - (fun (_, ((fwd, loop_fwds), _)) -> - let fwd = - if fwd.Pure.signature.info.effect_info.is_rec then - [ (fwd.def_id, None) ] + (fun { fwd; _ } -> + let fwd_f = + if fwd.f.Pure.signature.info.effect_info.is_rec then + [ (fwd.f.def_id, None) ] else [] in let loop_fwds = List.map (fun (def : Pure.fun_decl) -> [ (def.def_id, def.loop_id) ]) - loop_fwds + fwd.loops in - fwd :: loop_fwds) + fwd_f :: loop_fwds) trans_funs in let rec_functions : PureUtils.fun_loop_id list = @@ -958,22 +1028,70 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : in let rec_functions = PureUtils.FunLoopIdSet.of_list rec_functions in - (* Register unique names for all the top-level types, globals and functions. + (* Put the translated definitions in maps *) + let trans_types = + Pure.TypeDeclId.Map.of_list + (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) + in + let trans_funs : pure_fun_translation A.FunDeclId.Map.t = + A.FunDeclId.Map.of_list + (List.map + (fun (trans : pure_fun_translation) -> (trans.fwd.f.def_id, trans)) + trans_funs) + in + + (* Put everything in the context *) + let ctx = + let trans_trait_decls = + T.TraitDeclId.Map.of_list + (List.map + (fun (d : Pure.trait_decl) -> (d.def_id, d)) + trans_trait_decls) + in + let trans_trait_impls = + T.TraitImplId.Map.of_list + (List.map + (fun (d : Pure.trait_impl) -> (d.def_id, d)) + trans_trait_impls) + in + { + ExtractBase.crate; + trans_ctx; + names_maps; + fmt; + indent_incr = 2; + use_dep_ite = !Config.backend = Lean && !Config.extract_decreases_clauses; + fun_name_info = PureUtils.RegularFunIdMap.empty; + trait_decl_id = None (* None by default *); + is_provided_method = false (* false by default *); + trans_trait_decls; + trans_trait_impls; + trans_types; + trans_funs; + functions_with_decreases_clause = rec_functions; + types_filter_type_args_map = Pure.TypeDeclId.Map.empty; + funs_filter_type_args_map = Pure.FunDeclId.Map.empty; + trait_impls_filter_type_args_map = Pure.TraitImplId.Map.empty; + } + in + + (* Register unique names for all the top-level types, globals, functions... * Note that the order in which we generate the names doesn't matter: * we just need to generate a mapping from identifier to name, and make * sure there are no name clashes. *) let ctx = List.fold_left (fun ctx def -> Extract.extract_type_decl_register_names ctx def) - ctx trans_types + ctx + (Pure.TypeDeclId.Map.values trans_types) in let ctx = List.fold_left - (fun ctx (keep_fwd, defs) -> + (fun ctx (trans : pure_fun_translation) -> (* If requested by the user, register termination measures and decreases proofs for all the recursive functions *) - let fwd_def = fst (fst defs) in + let fwd_def = trans.fwd.f in let gen_decr_clause (def : Pure.fun_decl) = !Config.extract_decreases_clauses && PureUtils.FunLoopIdSet.mem @@ -984,10 +1102,9 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : * those are handled later *) let is_global = fwd_def.Pure.is_global_decl_body in if is_global then ctx - else - Extract.extract_fun_decl_register_names ctx keep_fwd gen_decr_clause - defs) - ctx trans_funs + else Extract.extract_fun_decl_register_names ctx gen_decr_clause trans) + ctx + (A.FunDeclId.Map.values trans_funs) in let ctx = @@ -995,6 +1112,16 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (A.GlobalDeclId.Map.values crate.globals) in + let ctx = + List.fold_left Extract.extract_trait_decl_register_names ctx + trans_trait_decls + in + + let ctx = + List.fold_left Extract.extract_trait_impl_register_names ctx + trans_trait_impls + in + (* Open the output file *) (* First compute the filename by replacing the extension and converting the * case (rust module names are snake case) *) @@ -1023,19 +1150,6 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (namespace, crate_name, Filename.concat dest_dir crate_name) in - (* Put the translated definitions in maps *) - let trans_types = - Pure.TypeDeclId.Map.of_list - (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) - in - let trans_funs = - A.FunDeclId.Map.of_list - (List.map - (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> - ((fst fd).def_id, (keep_fwd, (fd, bdl)))) - trans_funs) - in - let mkdir_if dest_dir = if not (Sys.file_exists dest_dir) then ( log#linfo (lazy ("Creating missing directory: " ^ dest_dir)); @@ -1091,16 +1205,6 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : in (* Extract the file(s) *) - let gen_ctx = - { - crate; - extract_ctx = ctx; - trans_types; - trans_funs; - functions_with_decreases_clause = rec_functions; - } - in - let module_delimiter = match !Config.backend with | FStar -> "." @@ -1136,6 +1240,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : extract_decreases_clauses = !Config.extract_decreases_clauses; extract_template_decreases_clauses = false; extract_fun_decls = false; + extract_trait_decls = false; + extract_trait_impls = false; extract_transparent = true; extract_opaque = false; extract_state_type = false; @@ -1147,7 +1253,9 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (* Check if there are opaque types and functions - in which case we need * to split *) - let has_opaque_types, has_opaque_funs = module_has_opaque_decls gen_ctx in + let has_opaque_types, has_opaque_funs = + crate_has_opaque_non_builtin_decls ctx true + in let has_opaque_types = has_opaque_types || !Config.use_state in (* Extract the types *) @@ -1168,6 +1276,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : { base_gen_config with extract_types = true; + extract_trait_decls = true; extract_opaque = true; extract_state_type = !Config.use_state; interface = has_opaque_types; @@ -1186,7 +1295,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : custom_includes = []; } in - extract_file types_config gen_ctx file_info; + extract_file types_config ctx file_info; (* Extract the template clauses *) (if needs_clauses_module && !Config.extract_template_decreases_clauses then @@ -1214,9 +1323,9 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : custom_includes = []; } in - extract_file template_clauses_config gen_ctx file_info); + extract_file template_clauses_config ctx file_info); - (* Extract the opaque functions, if needed *) + (* Extract the opaque declarations, if needed *) let opaque_funs_module = if has_opaque_funs then ( (* In the case of Lean we generate a template file *) @@ -1244,17 +1353,13 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : { base_gen_config with extract_fun_decls = true; + extract_trait_impls = true; + extract_globals = true; extract_transparent = false; extract_opaque = true; interface = true; } in - let gen_ctx = - { - gen_ctx with - extract_ctx = { gen_ctx.extract_ctx with use_opaque_pre = false }; - } - in let file_info = { filename = opaque_filename; @@ -1268,7 +1373,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : custom_includes = [ types_module ]; } in - extract_file opaque_config gen_ctx file_info; + extract_file opaque_config ctx file_info; (* Return the additional dependencies *) [ opaque_imported_module ]) else [] @@ -1281,6 +1386,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : { base_gen_config with extract_fun_decls = true; + extract_trait_impls = true; extract_globals = true; test_trans_unit_functions = !Config.test_trans_unit_functions; } @@ -1307,7 +1413,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : [ types_module ] @ opaque_funs_module @ clauses_module; } in - extract_file fun_config gen_ctx file_info) + extract_file fun_config ctx file_info) else let gen_config = { @@ -1316,6 +1422,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : extract_template_decreases_clauses = !Config.extract_template_decreases_clauses; extract_fun_decls = true; + extract_trait_decls = true; + extract_trait_impls = true; extract_transparent = true; extract_opaque = true; extract_state_type = !Config.use_state; @@ -1337,7 +1445,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : custom_includes = []; } in - extract_file gen_config gen_ctx file_info); + extract_file gen_config ctx file_info); (* Generate the build file *) match !Config.backend with diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index ba5e237b..3427fd43 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -10,64 +10,69 @@ module FA = FunsAnalysis (** The local logger *) let log = L.translate_log -type type_context = C.type_context [@@deriving show] - -type fun_context = { - fun_decls : A.fun_decl A.FunDeclId.Map.t; - fun_infos : FA.fun_info A.FunDeclId.Map.t; -} -[@@deriving show] +type trans_ctx = C.decls_ctx [@@deriving show] +type fun_and_loops = { f : Pure.fun_decl; loops : Pure.fun_decl list } +type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list -type global_context = C.global_context [@@deriving show] +type pure_fun_translation = { + keep_fwd : bool; + (** Should we extract the forward function? -type trans_ctx = { - type_context : type_context; - fun_context : fun_context; - global_context : global_context; + If the forward function returns `()` and there is exactly one + backward function, we may merge the forward into the backward + function and thus don't extract the forward function)? + *) + fwd : fun_and_loops; + backs : fun_and_loops list; } -type fun_and_loops = Pure.fun_decl * Pure.fun_decl list -type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list -type pure_fun_translation = fun_and_loops * fun_and_loops list +let trans_ctx_to_type_formatter (ctx : trans_ctx) + (type_params : Pure.type_var list) + (const_generic_params : Pure.const_generic_var list) : + PrintPure.type_formatter = + let type_decls = ctx.type_ctx.type_decls in + let global_decls = ctx.global_ctx.global_decls in + let trait_decls = ctx.trait_decls_ctx.trait_decls in + let trait_impls = ctx.trait_impls_ctx.trait_impls in + PrintPure.mk_type_formatter type_decls global_decls trait_decls trait_impls + type_params const_generic_params let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = - let type_params = def.type_params in - let cg_params = def.const_generic_params in - let type_decls = ctx.type_context.type_decls in - let global_decls = ctx.global_context.global_decls in + let generics = def.generics in let fmt = - PrintPure.mk_type_formatter type_decls global_decls type_params cg_params + trans_ctx_to_type_formatter ctx generics.types generics.const_generics in PrintPure.type_decl_to_string fmt def let type_id_to_string (ctx : trans_ctx) (id : Pure.TypeDeclId.id) : string = Print.fun_name_to_string - (Pure.TypeDeclId.Map.find id ctx.type_context.type_decls).name + (Pure.TypeDeclId.Map.find id ctx.type_ctx.type_decls).name + +let trans_ctx_to_ast_formatter (ctx : trans_ctx) + (type_params : Pure.type_var list) + (const_generic_params : Pure.const_generic_var list) : + PrintPure.ast_formatter = + let type_decls = ctx.type_ctx.type_decls in + let fun_decls = ctx.fun_ctx.fun_decls in + let global_decls = ctx.global_ctx.global_decls in + let trait_decls = ctx.trait_decls_ctx.trait_decls in + let trait_impls = ctx.trait_impls_ctx.trait_impls in + PrintPure.mk_ast_formatter type_decls fun_decls global_decls trait_decls + trait_impls type_params const_generic_params let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = - let type_params = sg.type_params in - let cg_params = sg.const_generic_params in - let type_decls = ctx.type_context.type_decls in - let fun_decls = ctx.fun_context.fun_decls in - let global_decls = ctx.global_context.global_decls in + let generics = sg.generics in let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + trans_ctx_to_ast_formatter ctx generics.types generics.const_generics in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = - let type_params = def.signature.type_params in - let cg_params = def.signature.const_generic_params in - let type_decls = ctx.type_context.type_decls in - let fun_decls = ctx.fun_context.fun_decls in - let global_decls = ctx.global_context.global_decls in + let generics = def.signature.generics in let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + trans_ctx_to_ast_formatter ctx generics.types generics.const_generics in PrintPure.fun_decl_to_string fmt def let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = - Print.fun_name_to_string - (A.FunDeclId.Map.find id ctx.fun_context.fun_decls).name + Print.fun_name_to_string (A.FunDeclId.Map.find id ctx.fun_ctx.fun_decls).name diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 925f6d39..38d350b1 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -14,11 +14,10 @@ type expl_info = subtype_info [@@deriving show] type type_borrows_info = { contains_static : bool; - (** Does the type (transitively) contains a static borrow? *) - contains_borrow : bool; - (** Does the type (transitively) contains a borrow? *) + (** Does the type (transitively) contain a static borrow? *) + contains_borrow : bool; (** Does the type (transitively) contain a borrow? *) contains_nested_borrows : bool; - (** Does the type (transitively) contains nested borrows? *) + (** Does the type (transitively) contain nested borrows? *) contains_borrow_under_mut : bool; } [@@deriving show] @@ -61,7 +60,7 @@ let initialize_g_type_info (param_infos : 'p) : 'p g_type_info = let initialize_type_decl_info (def : type_decl) : type_decl_info = let param_info = { under_borrow = false; under_mut_borrow = false } in - let param_infos = List.map (fun _ -> param_info) def.type_params in + let param_infos = List.map (fun _ -> param_info) def.generics.types in initialize_g_type_info param_infos let type_decl_info_to_partial_type_info (info : type_decl_info) : @@ -122,7 +121,7 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) (ty : 'r ty) : partial_type_info = match ty with - | Literal _ | Never -> ty_info + | Literal _ | Never | TraitType _ -> ty_info | TypeVar var_id -> ( (* Update the information for the proper parameter, if necessary *) match ty_info.param_infos with @@ -169,22 +168,21 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) in (* Continue exploring *) analyze expl_info ty_info rty - | Adt - ( (Tuple | Assumed (Box | Vec | Option | Slice | Array | Str | Range)), - _, - tys, - _ ) -> + | RawPtr (rty, _) -> + (* TODO: not sure what to do here *) + analyze expl_info ty_info rty + | Adt ((Tuple | Assumed (Box | Slice | Array | Str)), generics) -> (* Nothing to update: just explore the type parameters *) List.fold_left (fun ty_info ty -> analyze expl_info ty_info ty) - ty_info tys - | Adt (AdtId adt_id, regions, tys, _cgs) -> + ty_info generics.types + | Adt (AdtId adt_id, generics) -> (* Lookup the information for this type definition *) let adt_info = TypeDeclId.Map.find adt_id infos in (* Update the type info with the information from the adt *) let ty_info = update_ty_info ty_info adt_info.borrows_info in (* Check if 'static appears in the region parameters *) - let found_static = List.exists r_is_static regions in + let found_static = List.exists r_is_static generics.regions in let borrows_info = ty_info.borrows_info in let borrows_info = { @@ -196,7 +194,7 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) let ty_info = { ty_info with borrows_info } in (* For every instantiated type parameter: update the exploration info * then explore the type *) - let params_tys = List.combine adt_info.param_infos tys in + let params_tys = List.combine adt_info.param_infos generics.types in let ty_info = List.fold_left (fun ty_info (param_info, ty) -> @@ -235,6 +233,14 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) in (* Return *) ty_info + | Arrow (inputs, output) -> + (* Just dive into the arrow *) + let ty_info = + List.fold_left + (fun ty_info ty -> analyze expl_info ty_info ty) + ty_info inputs + in + analyze expl_info ty_info output in (* Explore *) analyze expl_info_init ty_info ty diff --git a/compiler/Values.ml b/compiler/Values.ml index d884c319..de27e7a9 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -52,6 +52,10 @@ type sv_kind = (** The result of a loop join (when computing loop fixed points) *) | Aggregate (** A symbolic value we introduce in place of an aggregate value *) + | ConstGeneric + (** A symbolic value we introduce when using a const generic as a value *) + | TraitConst + (** A symbolic value we introduce when evaluating a trait associated constant *) [@@deriving show, ord] (** Ancestor for {!symbolic_value} iter visitor *) diff --git a/compiler/dune b/compiler/dune index 6785cad4..648c7325 100644 --- a/compiler/dune +++ b/compiler/dune @@ -12,6 +12,7 @@ (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) (libraries charon core_unix unionFind ocamlgraph) (modules + AssociatedTypes Assumed Collections Config @@ -22,6 +23,8 @@ ExpressionsUtils Extract ExtractBase + ExtractBuiltin + ExtractTypes FunsAnalysis Identifiers InterpreterBorrowsCore @@ -90,4 +93,4 @@ -g ;-dsource -warn-error - -5-8-9-11-14-33-20-21-26-27-39))) + -5@8-9-11-14-33-20-21-26-27-39))) diff --git a/tests/coq/array/Array.v b/tests/coq/array/Array.v new file mode 100644 index 00000000..825f73e0 --- /dev/null +++ b/tests/coq/array/Array.v @@ -0,0 +1,470 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [array] *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module Array. + +(** [array::AB] *) +Inductive AB_t := | AB_A : AB_t | AB_B : AB_t. + +(** [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition incr (x : u32) : result u32 := + u32_add x 1%u32. + +(** [array::array_to_shared_slice_]: forward function *) +Definition array_to_shared_slice_ + (T : Type) (s : array T 32%usize) : result (slice T) := + array_to_slice T 32%usize s +. + +(** [array::array_to_mut_slice_]: forward function *) +Definition array_to_mut_slice_ + (T : Type) (s : array T 32%usize) : result (slice T) := + array_to_slice T 32%usize s +. + +(** [array::array_to_mut_slice_]: backward function 0 *) +Definition array_to_mut_slice__back + (T : Type) (s : array T 32%usize) (ret : slice T) : + result (array T 32%usize) + := + array_from_slice T 32%usize s ret +. + +(** [array::array_len]: forward function *) +Definition array_len (T : Type) (s : array T 32%usize) : result usize := + s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i +. + +(** [array::shared_array_len]: forward function *) +Definition shared_array_len (T : Type) (s : array T 32%usize) : result usize := + s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i +. + +(** [array::shared_slice_len]: forward function *) +Definition shared_slice_len (T : Type) (s : slice T) : result usize := + let i := slice_len T s in Return i +. + +(** [array::index_array_shared]: forward function *) +Definition index_array_shared + (T : Type) (s : array T 32%usize) (i : usize) : result T := + array_index_usize T 32%usize s i +. + +(** [array::index_array_u32]: forward function *) +Definition index_array_u32 (s : array u32 32%usize) (i : usize) : result u32 := + array_index_usize u32 32%usize s i +. + +(** [array::index_array_copy]: forward function *) +Definition index_array_copy (x : array u32 32%usize) : result u32 := + array_index_usize u32 32%usize x 0%usize +. + +(** [array::index_mut_array]: forward function *) +Definition index_mut_array + (T : Type) (s : array T 32%usize) (i : usize) : result T := + array_index_usize T 32%usize s i +. + +(** [array::index_mut_array]: backward function 0 *) +Definition index_mut_array_back + (T : Type) (s : array T 32%usize) (i : usize) (ret : T) : + result (array T 32%usize) + := + array_update_usize T 32%usize s i ret +. + +(** [array::index_slice]: forward function *) +Definition index_slice (T : Type) (s : slice T) (i : usize) : result T := + slice_index_usize T s i +. + +(** [array::index_mut_slice]: forward function *) +Definition index_mut_slice (T : Type) (s : slice T) (i : usize) : result T := + slice_index_usize T s i +. + +(** [array::index_mut_slice]: backward function 0 *) +Definition index_mut_slice_back + (T : Type) (s : slice T) (i : usize) (ret : T) : result (slice T) := + slice_update_usize T s i ret +. + +(** [array::slice_subslice_shared_]: forward function *) +Definition slice_subslice_shared_ + (x : slice u32) (y : usize) (z : usize) : result (slice u32) := + core_slice_index_Slice_index u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::slice_subslice_mut_]: forward function *) +Definition slice_subslice_mut_ + (x : slice u32) (y : usize) (z : usize) : result (slice u32) := + core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::slice_subslice_mut_]: backward function 0 *) +Definition slice_subslice_mut__back + (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : + result (slice u32) + := + core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret +. + +(** [array::array_to_slice_shared_]: forward function *) +Definition array_to_slice_shared_ + (x : array u32 32%usize) : result (slice u32) := + array_to_slice u32 32%usize x +. + +(** [array::array_to_slice_mut_]: forward function *) +Definition array_to_slice_mut_ (x : array u32 32%usize) : result (slice u32) := + array_to_slice u32 32%usize x +. + +(** [array::array_to_slice_mut_]: backward function 0 *) +Definition array_to_slice_mut__back + (x : array u32 32%usize) (ret : slice u32) : result (array u32 32%usize) := + array_from_slice u32 32%usize x ret +. + +(** [array::array_subslice_shared_]: forward function *) +Definition array_subslice_shared_ + (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := + core_array_Array_index u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::array_subslice_mut_]: forward function *) +Definition array_subslice_mut_ + (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := + core_array_Array_index_mut u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::array_subslice_mut_]: backward function 0 *) +Definition array_subslice_mut__back + (x : array u32 32%usize) (y : usize) (z : usize) (ret : slice u32) : + result (array u32 32%usize) + := + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret +. + +(** [array::index_slice_0]: forward function *) +Definition index_slice_0 (T : Type) (s : slice T) : result T := + slice_index_usize T s 0%usize +. + +(** [array::index_array_0]: forward function *) +Definition index_array_0 (T : Type) (s : array T 32%usize) : result T := + array_index_usize T 32%usize s 0%usize +. + +(** [array::index_index_array]: forward function *) +Definition index_index_array + (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : + result u32 + := + a <- array_index_usize (array u32 32%usize) 32%usize s i; + array_index_usize u32 32%usize a j +. + +(** [array::update_update_array]: forward function *) +Definition update_update_array + (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : + result unit + := + a <- array_index_usize (array u32 32%usize) 32%usize s i; + a0 <- array_update_usize u32 32%usize a j 0%u32; + _ <- array_update_usize (array u32 32%usize) 32%usize s i a0; + Return tt +. + +(** [array::array_local_deep_copy]: forward function *) +Definition array_local_deep_copy (x : array u32 32%usize) : result unit := + Return tt +. + +(** [array::take_array]: forward function *) +Definition take_array (a : array u32 2%usize) : result unit := + Return tt. + +(** [array::take_array_borrow]: forward function *) +Definition take_array_borrow (a : array u32 2%usize) : result unit := + Return tt +. + +(** [array::take_slice]: forward function *) +Definition take_slice (s : slice u32) : result unit := + Return tt. + +(** [array::take_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition take_mut_slice (s : slice u32) : result (slice u32) := + Return s. + +(** [array::take_all]: forward function *) +Definition take_all : result unit := + _ <- take_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + _ <- take_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + _ <- take_slice s; + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s1 <- take_mut_slice s0; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; + Return tt +. + +(** [array::index_array]: forward function *) +Definition index_array (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize +. + +(** [array::index_array_borrow]: forward function *) +Definition index_array_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize +. + +(** [array::index_slice_u32_0]: forward function *) +Definition index_slice_u32_0 (x : slice u32) : result u32 := + slice_index_usize u32 x 0%usize +. + +(** [array::index_mut_slice_u32_0]: forward function *) +Definition index_mut_slice_u32_0 (x : slice u32) : result u32 := + slice_index_usize u32 x 0%usize +. + +(** [array::index_mut_slice_u32_0]: backward function 0 *) +Definition index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) := + _ <- slice_index_usize u32 x 0%usize; Return x +. + +(** [array::index_all]: forward function *) +Definition index_all : result u32 := + i <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i0 <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i1 <- u32_add i i0; + i2 <- index_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i3 <- u32_add i1 i2; + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i4 <- index_slice_u32_0 s; + i5 <- u32_add i3 i4; + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i6 <- index_mut_slice_u32_0 s0; + i7 <- u32_add i5 i6; + s1 <- index_mut_slice_u32_0_back s0; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; + Return i7 +. + +(** [array::update_array]: forward function *) +Definition update_array (x : array u32 2%usize) : result unit := + _ <- array_update_usize u32 2%usize x 0%usize 1%u32; Return tt +. + +(** [array::update_array_mut_borrow]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition update_array_mut_borrow + (x : array u32 2%usize) : result (array u32 2%usize) := + array_update_usize u32 2%usize x 0%usize 1%u32 +. + +(** [array::update_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition update_mut_slice (x : slice u32) : result (slice u32) := + slice_update_usize u32 x 0%usize 1%u32 +. + +(** [array::update_all]: forward function *) +Definition update_all : result unit := + _ <- update_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + x <- update_array_mut_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s <- array_to_slice u32 2%usize x; + s0 <- update_mut_slice s; + _ <- array_from_slice u32 2%usize x s0; + Return tt +. + +(** [array::range_all]: forward function *) +Definition range_all : result unit := + s <- + core_array_Array_index_mut u32 (core_ops_range_Range usize) 4%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) + {| + core_ops_range_Range_start := 1%usize; + core_ops_range_Range_end_ := 3%usize + |}; + s0 <- update_mut_slice s; + _ <- + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) + {| + core_ops_range_Range_start := 1%usize; + core_ops_range_Range_end_ := 3%usize + |} s0; + Return tt +. + +(** [array::deref_array_borrow]: forward function *) +Definition deref_array_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize +. + +(** [array::deref_array_mut_borrow]: forward function *) +Definition deref_array_mut_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize +. + +(** [array::deref_array_mut_borrow]: backward function 0 *) +Definition deref_array_mut_borrow_back + (x : array u32 2%usize) : result (array u32 2%usize) := + _ <- array_index_usize u32 2%usize x 0%usize; Return x +. + +(** [array::take_array_t]: forward function *) +Definition take_array_t (a : array AB_t 2%usize) : result unit := + Return tt. + +(** [array::non_copyable_array]: forward function *) +Definition non_copyable_array : result unit := + _ <- take_array_t (mk_array AB_t 2%usize [ AB_A; AB_B ]); Return tt +. + +(** [array::sum]: loop 0: forward function *) +Fixpoint sum_loop + (n : nat) (s : slice u32) (sum0 : u32) (i : usize) : result u32 := + match n with + | O => Fail_ OutOfFuel + | S n0 => + let i0 := slice_len u32 s in + if i s< i0 + then ( + i1 <- slice_index_usize u32 s i; + sum1 <- u32_add sum0 i1; + i2 <- usize_add i 1%usize; + sum_loop n0 s sum1 i2) + else Return sum0 + end +. + +(** [array::sum]: forward function *) +Definition sum (n : nat) (s : slice u32) : result u32 := + sum_loop n s 0%u32 0%usize +. + +(** [array::sum2]: loop 0: forward function *) +Fixpoint sum2_loop + (n : nat) (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : + result u32 + := + match n with + | O => Fail_ OutOfFuel + | S n0 => + let i0 := slice_len u32 s in + if i s< i0 + then ( + i1 <- slice_index_usize u32 s i; + i2 <- slice_index_usize u32 s2 i; + i3 <- u32_add i1 i2; + sum1 <- u32_add sum0 i3; + i4 <- usize_add i 1%usize; + sum2_loop n0 s s2 sum1 i4) + else Return sum0 + end +. + +(** [array::sum2]: forward function *) +Definition sum2 (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := + let i := slice_len u32 s in + let i0 := slice_len u32 s2 in + if negb (i s= i0) then Fail_ Failure else sum2_loop n s s2 0%u32 0%usize +. + +(** [array::f0]: forward function *) +Definition f0 : result unit := + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); + s0 <- slice_update_usize u32 s 0%usize 1%u32; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) s0; + Return tt +. + +(** [array::f1]: forward function *) +Definition f1 : result unit := + _ <- + array_update_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) + 0%usize 1%u32; + Return tt +. + +(** [array::f2]: forward function *) +Definition f2 (i : u32) : result unit := + Return tt. + +(** [array::f4]: forward function *) +Definition f4 + (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := + core_array_Array_index u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::f3]: forward function *) +Definition f3 (n : nat) : result u32 := + i <- + array_index_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) + 0%usize; + _ <- f2 i; + let b := array_repeat u32 32%usize 0%u32 in + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); + s0 <- f4 b 16%usize 18%usize; + sum2 n s s0 +. + +(** [array::SZ] *) +Definition sz_body : result usize := Return 32%usize. +Definition sz_c : usize := sz_body%global. + +(** [array::f5]: forward function *) +Definition f5 (x : array u32 32%usize) : result u32 := + array_index_usize u32 32%usize x 0%usize +. + +(** [array::ite]: forward function *) +Definition ite : result unit := + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s1 <- index_mut_slice_u32_0_back s0; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; + s2 <- index_mut_slice_u32_0_back s; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s2; + Return tt +. + +End Array . diff --git a/tests/coq/array/Array_Funs.v b/tests/coq/array/Array_Funs.v deleted file mode 100644 index 6d791873..00000000 --- a/tests/coq/array/Array_Funs.v +++ /dev/null @@ -1,467 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [array]: function definitions *) -Require Import Primitives. -Import Primitives. -Require Import Coq.ZArith.ZArith. -Require Import List. -Import ListNotations. -Local Open Scope Primitives_scope. -Require Export Array_Types. -Import Array_Types. -Module Array_Funs. - -(** [array::array_to_shared_slice_]: forward function *) -Definition array_to_shared_slice__fwd - (T : Type) (s : array T 32%usize) : result (slice T) := - array_to_slice_shared T 32%usize s -. - -(** [array::array_to_mut_slice_]: forward function *) -Definition array_to_mut_slice__fwd - (T : Type) (s : array T 32%usize) : result (slice T) := - array_to_slice_mut_fwd T 32%usize s -. - -(** [array::array_to_mut_slice_]: backward function 0 *) -Definition array_to_mut_slice__back - (T : Type) (s : array T 32%usize) (ret : slice T) : - result (array T 32%usize) - := - array_to_slice_mut_back T 32%usize s ret -. - -(** [array::array_len]: forward function *) -Definition array_len_fwd (T : Type) (s : array T 32%usize) : result usize := - s0 <- array_to_slice_shared T 32%usize s; let i := slice_len T s0 in Return i -. - -(** [array::shared_array_len]: forward function *) -Definition shared_array_len_fwd - (T : Type) (s : array T 32%usize) : result usize := - s0 <- array_to_slice_shared T 32%usize s; let i := slice_len T s0 in Return i -. - -(** [array::shared_slice_len]: forward function *) -Definition shared_slice_len_fwd (T : Type) (s : slice T) : result usize := - let i := slice_len T s in Return i -. - -(** [array::index_array_shared]: forward function *) -Definition index_array_shared_fwd - (T : Type) (s : array T 32%usize) (i : usize) : result T := - array_index_shared T 32%usize s i -. - -(** [array::index_array_u32]: forward function *) -Definition index_array_u32_fwd - (s : array u32 32%usize) (i : usize) : result u32 := - array_index_shared u32 32%usize s i -. - -(** [array::index_array_generic]: forward function *) -Definition index_array_generic_fwd - (N : usize) (s : array u32 N) (i : usize) : result u32 := - array_index_shared u32 N s i -. - -(** [array::index_array_generic_call]: forward function *) -Definition index_array_generic_call_fwd - (N : usize) (s : array u32 N) (i : usize) : result u32 := - index_array_generic_fwd N s i -. - -(** [array::index_array_copy]: forward function *) -Definition index_array_copy_fwd (x : array u32 32%usize) : result u32 := - array_index_shared u32 32%usize x 0%usize -. - -(** [array::index_mut_array]: forward function *) -Definition index_mut_array_fwd - (T : Type) (s : array T 32%usize) (i : usize) : result T := - array_index_mut_fwd T 32%usize s i -. - -(** [array::index_mut_array]: backward function 0 *) -Definition index_mut_array_back - (T : Type) (s : array T 32%usize) (i : usize) (ret : T) : - result (array T 32%usize) - := - array_index_mut_back T 32%usize s i ret -. - -(** [array::index_slice]: forward function *) -Definition index_slice_fwd (T : Type) (s : slice T) (i : usize) : result T := - slice_index_shared T s i -. - -(** [array::index_mut_slice]: forward function *) -Definition index_mut_slice_fwd - (T : Type) (s : slice T) (i : usize) : result T := - slice_index_mut_fwd T s i -. - -(** [array::index_mut_slice]: backward function 0 *) -Definition index_mut_slice_back - (T : Type) (s : slice T) (i : usize) (ret : T) : result (slice T) := - slice_index_mut_back T s i ret -. - -(** [array::slice_subslice_shared_]: forward function *) -Definition slice_subslice_shared__fwd - (x : slice u32) (y : usize) (z : usize) : result (slice u32) := - slice_subslice_shared u32 x (mk_range y z) -. - -(** [array::slice_subslice_mut_]: forward function *) -Definition slice_subslice_mut__fwd - (x : slice u32) (y : usize) (z : usize) : result (slice u32) := - slice_subslice_mut_fwd u32 x (mk_range y z) -. - -(** [array::slice_subslice_mut_]: backward function 0 *) -Definition slice_subslice_mut__back - (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : - result (slice u32) - := - slice_subslice_mut_back u32 x (mk_range y z) ret -. - -(** [array::array_to_slice_shared_]: forward function *) -Definition array_to_slice_shared__fwd - (x : array u32 32%usize) : result (slice u32) := - array_to_slice_shared u32 32%usize x -. - -(** [array::array_to_slice_mut_]: forward function *) -Definition array_to_slice_mut__fwd - (x : array u32 32%usize) : result (slice u32) := - array_to_slice_mut_fwd u32 32%usize x -. - -(** [array::array_to_slice_mut_]: backward function 0 *) -Definition array_to_slice_mut__back - (x : array u32 32%usize) (ret : slice u32) : result (array u32 32%usize) := - array_to_slice_mut_back u32 32%usize x ret -. - -(** [array::array_subslice_shared_]: forward function *) -Definition array_subslice_shared__fwd - (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := - array_subslice_shared u32 32%usize x (mk_range y z) -. - -(** [array::array_subslice_mut_]: forward function *) -Definition array_subslice_mut__fwd - (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := - array_subslice_mut_fwd u32 32%usize x (mk_range y z) -. - -(** [array::array_subslice_mut_]: backward function 0 *) -Definition array_subslice_mut__back - (x : array u32 32%usize) (y : usize) (z : usize) (ret : slice u32) : - result (array u32 32%usize) - := - array_subslice_mut_back u32 32%usize x (mk_range y z) ret -. - -(** [array::index_slice_0]: forward function *) -Definition index_slice_0_fwd (T : Type) (s : slice T) : result T := - slice_index_shared T s 0%usize -. - -(** [array::index_array_0]: forward function *) -Definition index_array_0_fwd (T : Type) (s : array T 32%usize) : result T := - array_index_shared T 32%usize s 0%usize -. - -(** [array::index_index_array]: forward function *) -Definition index_index_array_fwd - (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : - result u32 - := - a <- array_index_shared (array u32 32%usize) 32%usize s i; - array_index_shared u32 32%usize a j -. - -(** [array::update_update_array]: forward function *) -Definition update_update_array_fwd - (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : - result unit - := - a <- array_index_mut_fwd (array u32 32%usize) 32%usize s i; - a0 <- array_index_mut_back u32 32%usize a j 0%u32; - _ <- array_index_mut_back (array u32 32%usize) 32%usize s i a0; - Return tt -. - -(** [array::array_local_deep_copy]: forward function *) -Definition array_local_deep_copy_fwd (x : array u32 32%usize) : result unit := - Return tt -. - -(** [array::take_array]: forward function *) -Definition take_array_fwd (a : array u32 2%usize) : result unit := - Return tt. - -(** [array::take_array_borrow]: forward function *) -Definition take_array_borrow_fwd (a : array u32 2%usize) : result unit := - Return tt -. - -(** [array::take_slice]: forward function *) -Definition take_slice_fwd (s : slice u32) : result unit := - Return tt. - -(** [array::take_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -Definition take_mut_slice_fwd_back (s : slice u32) : result (slice u32) := - Return s -. - -(** [array::take_all]: forward function *) -Definition take_all_fwd : result unit := - _ <- take_array_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - _ <- take_array_borrow_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s <- - array_to_slice_shared u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - _ <- take_slice_fwd s; - s0 <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s1 <- take_mut_slice_fwd_back s0; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) - s1; - Return tt -. - -(** [array::index_array]: forward function *) -Definition index_array_fwd (x : array u32 2%usize) : result u32 := - array_index_shared u32 2%usize x 0%usize -. - -(** [array::index_array_borrow]: forward function *) -Definition index_array_borrow_fwd (x : array u32 2%usize) : result u32 := - array_index_shared u32 2%usize x 0%usize -. - -(** [array::index_slice_u32_0]: forward function *) -Definition index_slice_u32_0_fwd (x : slice u32) : result u32 := - slice_index_shared u32 x 0%usize -. - -(** [array::index_mut_slice_u32_0]: forward function *) -Definition index_mut_slice_u32_0_fwd (x : slice u32) : result u32 := - slice_index_shared u32 x 0%usize -. - -(** [array::index_mut_slice_u32_0]: backward function 0 *) -Definition index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) := - _ <- slice_index_shared u32 x 0%usize; Return x -. - -(** [array::index_all]: forward function *) -Definition index_all_fwd : result u32 := - i <- index_array_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i0 <- index_array_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i1 <- u32_add i i0; - i2 <- index_array_borrow_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i3 <- u32_add i1 i2; - s <- - array_to_slice_shared u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i4 <- index_slice_u32_0_fwd s; - i5 <- u32_add i3 i4; - s0 <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i6 <- index_mut_slice_u32_0_fwd s0; - i7 <- u32_add i5 i6; - s1 <- index_mut_slice_u32_0_back s0; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) - s1; - Return i7 -. - -(** [array::update_array]: forward function *) -Definition update_array_fwd (x : array u32 2%usize) : result unit := - _ <- array_index_mut_back u32 2%usize x 0%usize 1%u32; Return tt -. - -(** [array::update_array_mut_borrow]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -Definition update_array_mut_borrow_fwd_back - (x : array u32 2%usize) : result (array u32 2%usize) := - array_index_mut_back u32 2%usize x 0%usize 1%u32 -. - -(** [array::update_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -Definition update_mut_slice_fwd_back (x : slice u32) : result (slice u32) := - slice_index_mut_back u32 x 0%usize 1%u32 -. - -(** [array::update_all]: forward function *) -Definition update_all_fwd : result unit := - _ <- update_array_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - x <- - update_array_mut_borrow_fwd_back (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s <- array_to_slice_mut_fwd u32 2%usize x; - s0 <- update_mut_slice_fwd_back s; - _ <- array_to_slice_mut_back u32 2%usize x s0; - Return tt -. - -(** [array::range_all]: forward function *) -Definition range_all_fwd : result unit := - s <- - array_subslice_mut_fwd u32 4%usize - (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) (mk_range 1%usize - 3%usize); - s0 <- update_mut_slice_fwd_back s; - _ <- - array_subslice_mut_back u32 4%usize - (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) (mk_range 1%usize - 3%usize) s0; - Return tt -. - -(** [array::deref_array_borrow]: forward function *) -Definition deref_array_borrow_fwd (x : array u32 2%usize) : result u32 := - array_index_shared u32 2%usize x 0%usize -. - -(** [array::deref_array_mut_borrow]: forward function *) -Definition deref_array_mut_borrow_fwd (x : array u32 2%usize) : result u32 := - array_index_shared u32 2%usize x 0%usize -. - -(** [array::deref_array_mut_borrow]: backward function 0 *) -Definition deref_array_mut_borrow_back - (x : array u32 2%usize) : result (array u32 2%usize) := - _ <- array_index_shared u32 2%usize x 0%usize; Return x -. - -(** [array::take_array_t]: forward function *) -Definition take_array_t_fwd (a : array T_t 2%usize) : result unit := - Return tt. - -(** [array::non_copyable_array]: forward function *) -Definition non_copyable_array_fwd : result unit := - _ <- take_array_t_fwd (mk_array T_t 2%usize [ TA; TB ]); Return tt -. - -(** [array::sum]: loop 0: forward function *) -Fixpoint sum_loop_fwd - (n : nat) (s : slice u32) (sum : u32) (i : usize) : result u32 := - match n with - | O => Fail_ OutOfFuel - | S n0 => - let i0 := slice_len u32 s in - if i s< i0 - then ( - i1 <- slice_index_shared u32 s i; - sum0 <- u32_add sum i1; - i2 <- usize_add i 1%usize; - sum_loop_fwd n0 s sum0 i2) - else Return sum - end -. - -(** [array::sum]: forward function *) -Definition sum_fwd (n : nat) (s : slice u32) : result u32 := - sum_loop_fwd n s 0%u32 0%usize -. - -(** [array::sum2]: loop 0: forward function *) -Fixpoint sum2_loop_fwd - (n : nat) (s : slice u32) (s2 : slice u32) (sum : u32) (i : usize) : - result u32 - := - match n with - | O => Fail_ OutOfFuel - | S n0 => - let i0 := slice_len u32 s in - if i s< i0 - then ( - i1 <- slice_index_shared u32 s i; - i2 <- slice_index_shared u32 s2 i; - i3 <- u32_add i1 i2; - sum0 <- u32_add sum i3; - i4 <- usize_add i 1%usize; - sum2_loop_fwd n0 s s2 sum0 i4) - else Return sum - end -. - -(** [array::sum2]: forward function *) -Definition sum2_fwd (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := - let i := slice_len u32 s in - let i0 := slice_len u32 s2 in - if negb (i s= i0) then Fail_ Failure else sum2_loop_fwd n s s2 0%u32 0%usize -. - -(** [array::f0]: forward function *) -Definition f0_fwd : result unit := - s <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); - s0 <- slice_index_mut_back u32 s 0%usize 1%u32; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) - s0; - Return tt -. - -(** [array::f1]: forward function *) -Definition f1_fwd : result unit := - _ <- - array_index_mut_back u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) - 0%usize 1%u32; - Return tt -. - -(** [array::f2]: forward function *) -Definition f2_fwd (i : u32) : result unit := - Return tt. - -(** [array::f4]: forward function *) -Definition f4_fwd - (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := - array_subslice_shared u32 32%usize x (mk_range y z) -. - -(** [array::f3]: forward function *) -Definition f3_fwd (n : nat) : result u32 := - i <- - array_index_shared u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) - 0%usize; - _ <- f2_fwd i; - s <- - array_to_slice_shared u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); - s0 <- - f4_fwd - (mk_array u32 32%usize [ - 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; - 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; - 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; - 0%u32; 0%u32 - ]) 16%usize 18%usize; - sum2_fwd n s s0 -. - -(** [array::ite]: forward function *) -Definition ite_fwd : result unit := - s <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s0 <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s1 <- index_mut_slice_u32_0_back s0; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) - s1; - s2 <- index_mut_slice_u32_0_back s; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) - s2; - Return tt -. - -End Array_Funs . diff --git a/tests/coq/array/Array_Types.v b/tests/coq/array/Array_Types.v deleted file mode 100644 index 7be6dc9b..00000000 --- a/tests/coq/array/Array_Types.v +++ /dev/null @@ -1,14 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [array]: type definitions *) -Require Import Primitives. -Import Primitives. -Require Import Coq.ZArith.ZArith. -Require Import List. -Import ListNotations. -Local Open Scope Primitives_scope. -Module Array_Types. - -(** [array::T] *) -Inductive T_t := | TA : T_t | TB : T_t. - -End Array_Types . diff --git a/tests/coq/array/Primitives.v b/tests/coq/array/Primitives.v index 71a2d9c3..85e38f01 100644 --- a/tests/coq/array/Primitives.v +++ b/tests/coq/array/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -394,12 +396,89 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -419,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -474,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. +Definition alloc_vec_Vec_insert_fwd (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result unit := + if to_Z i <? alloc_vec_Vec_length v then Return tt else Fail_ Failure. -Definition vec_insert_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i <? Z.of_nat (length l) then Return (list_update l (usize_to_nat i) x) else Fail_ Failure). -(* The **backward** function shouldn't be used *) -Definition vec_index_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. - -(* The **backward** function shouldn't be used *) -Definition vec_index_mut_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i <? Z.of_nat (length l) - then Return (list_update l (usize_to_nat i) x) - else Fail_ Failure). +(* [core::slice::index::Range:::get]: forward function *) +Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: forward function *) +Axiom core_slice_index_Range_get_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/array/_CoqProject b/tests/coq/array/_CoqProject index f33cefe6..87d8fc3d 100644 --- a/tests/coq/array/_CoqProject +++ b/tests/coq/array/_CoqProject @@ -3,6 +3,5 @@ -arg -w -arg all -Array_Funs.v Primitives.v -Array_Types.v +Array.v diff --git a/tests/coq/betree/BetreeMain_Funs.v b/tests/coq/betree/BetreeMain_Funs.v index 1e457433..261e8270 100644 --- a/tests/coq/betree/BetreeMain_Funs.v +++ b/tests/coq/betree/BetreeMain_Funs.v @@ -13,41 +13,41 @@ Import BetreeMain_Opaque. Module BetreeMain_Funs. (** [betree_main::betree::load_internal_node]: forward function *) -Definition betree_load_internal_node_fwd +Definition betree_load_internal_node (id : u64) (st : state) : - result (state * (Betree_list_t (u64 * Betree_message_t))) + result (state * (betree_List_t (u64 * betree_Message_t))) := - betree_utils_load_internal_node_fwd id st + betree_utils_load_internal_node id st . (** [betree_main::betree::store_internal_node]: forward function *) -Definition betree_store_internal_node_fwd - (id : u64) (content : Betree_list_t (u64 * Betree_message_t)) (st : state) : +Definition betree_store_internal_node + (id : u64) (content : betree_List_t (u64 * betree_Message_t)) (st : state) : result (state * unit) := - p <- betree_utils_store_internal_node_fwd id content st; + p <- betree_utils_store_internal_node id content st; let (st0, _) := p in Return (st0, tt) . (** [betree_main::betree::load_leaf_node]: forward function *) -Definition betree_load_leaf_node_fwd - (id : u64) (st : state) : result (state * (Betree_list_t (u64 * u64))) := - betree_utils_load_leaf_node_fwd id st +Definition betree_load_leaf_node + (id : u64) (st : state) : result (state * (betree_List_t (u64 * u64))) := + betree_utils_load_leaf_node id st . (** [betree_main::betree::store_leaf_node]: forward function *) -Definition betree_store_leaf_node_fwd - (id : u64) (content : Betree_list_t (u64 * u64)) (st : state) : +Definition betree_store_leaf_node + (id : u64) (content : betree_List_t (u64 * u64)) (st : state) : result (state * unit) := - p <- betree_utils_store_leaf_node_fwd id content st; + p <- betree_utils_store_leaf_node id content st; let (st0, _) := p in Return (st0, tt) . (** [betree_main::betree::fresh_node_id]: forward function *) -Definition betree_fresh_node_id_fwd (counter : u64) : result u64 := +Definition betree_fresh_node_id (counter : u64) : result u64 := _ <- u64_add counter 1%u64; Return counter . @@ -57,1142 +57,1121 @@ Definition betree_fresh_node_id_back (counter : u64) : result u64 := . (** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) -Definition betree_node_id_counter_new_fwd : result Betree_node_id_counter_t := - Return {| Betree_node_id_counter_next_node_id := 0%u64 |} +Definition betree_NodeIdCounter_new : result betree_NodeIdCounter_t := + Return {| betree_NodeIdCounter_next_node_id := 0%u64 |} . (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) -Definition betree_node_id_counter_fresh_id_fwd - (self : Betree_node_id_counter_t) : result u64 := - _ <- u64_add self.(Betree_node_id_counter_next_node_id) 1%u64; - Return self.(Betree_node_id_counter_next_node_id) +Definition betree_NodeIdCounter_fresh_id + (self : betree_NodeIdCounter_t) : result u64 := + _ <- u64_add self.(betree_NodeIdCounter_next_node_id) 1%u64; + Return self.(betree_NodeIdCounter_next_node_id) . (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) -Definition betree_node_id_counter_fresh_id_back - (self : Betree_node_id_counter_t) : result Betree_node_id_counter_t := - i <- u64_add self.(Betree_node_id_counter_next_node_id) 1%u64; - Return {| Betree_node_id_counter_next_node_id := i |} +Definition betree_NodeIdCounter_fresh_id_back + (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t := + i <- u64_add self.(betree_NodeIdCounter_next_node_id) 1%u64; + Return {| betree_NodeIdCounter_next_node_id := i |} . -(** [core::num::u64::{9}::MAX] *) -Definition core_num_u64_max_body : result u64 := - Return 18446744073709551615%u64 -. -Definition core_num_u64_max_c : u64 := core_num_u64_max_body%global. - (** [betree_main::betree::upsert_update]: forward function *) -Definition betree_upsert_update_fwd - (prev : option u64) (st : Betree_upsert_fun_state_t) : result u64 := +Definition betree_upsert_update + (prev : option u64) (st : betree_UpsertFunState_t) : result u64 := match prev with | None => match st with - | BetreeUpsertFunStateAdd v => Return v - | BetreeUpsertFunStateSub i => Return 0%u64 + | Betree_UpsertFunState_Add v => Return v + | Betree_UpsertFunState_Sub i => Return 0%u64 end | Some prev0 => match st with - | BetreeUpsertFunStateAdd v => - margin <- u64_sub core_num_u64_max_c prev0; - if margin s>= v then u64_add prev0 v else Return core_num_u64_max_c - | BetreeUpsertFunStateSub v => + | Betree_UpsertFunState_Add v => + margin <- u64_sub core_u64_max prev0; + if margin s>= v then u64_add prev0 v else Return core_u64_max + | Betree_UpsertFunState_Sub v => if prev0 s>= v then u64_sub prev0 v else Return 0%u64 end end . (** [betree_main::betree::List::{1}::len]: forward function *) -Fixpoint betree_list_len_fwd - (T : Type) (n : nat) (self : Betree_list_t T) : result u64 := +Fixpoint betree_List_len + (T : Type) (n : nat) (self : betree_List_t T) : result u64 := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeListCons t tl => i <- betree_list_len_fwd T n0 tl; u64_add 1%u64 i - | BetreeListNil => Return 0%u64 + | Betree_List_Cons t tl => i <- betree_List_len T n0 tl; u64_add 1%u64 i + | Betree_List_Nil => Return 0%u64 end end . (** [betree_main::betree::List::{1}::split_at]: forward function *) -Fixpoint betree_list_split_at_fwd - (T : Type) (n : nat) (self : Betree_list_t T) (n0 : u64) : - result ((Betree_list_t T) * (Betree_list_t T)) +Fixpoint betree_List_split_at + (T : Type) (n : nat) (self : betree_List_t T) (n0 : u64) : + result ((betree_List_t T) * (betree_List_t T)) := match n with | O => Fail_ OutOfFuel | S n1 => if n0 s= 0%u64 - then Return (BetreeListNil, self) + then Return (Betree_List_Nil, self) else match self with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => i <- u64_sub n0 1%u64; - p <- betree_list_split_at_fwd T n1 tl i; + p <- betree_List_split_at T n1 tl i; let (ls0, ls1) := p in let l := ls0 in - Return (BetreeListCons hd l, ls1) - | BetreeListNil => Fail_ Failure + Return (Betree_List_Cons hd l, ls1) + | Betree_List_Nil => Fail_ Failure end end . (** [betree_main::betree::List::{1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition betree_list_push_front_fwd_back - (T : Type) (self : Betree_list_t T) (x : T) : result (Betree_list_t T) := - let tl := mem_replace_fwd (Betree_list_t T) self BetreeListNil in +Definition betree_List_push_front + (T : Type) (self : betree_List_t T) (x : T) : result (betree_List_t T) := + let tl := core_mem_replace (betree_List_t T) self Betree_List_Nil in let l := tl in - Return (BetreeListCons x l) + Return (Betree_List_Cons x l) . (** [betree_main::betree::List::{1}::pop_front]: forward function *) -Definition betree_list_pop_front_fwd - (T : Type) (self : Betree_list_t T) : result T := - let ls := mem_replace_fwd (Betree_list_t T) self BetreeListNil in +Definition betree_List_pop_front + (T : Type) (self : betree_List_t T) : result T := + let ls := core_mem_replace (betree_List_t T) self Betree_List_Nil in match ls with - | BetreeListCons x tl => Return x - | BetreeListNil => Fail_ Failure + | Betree_List_Cons x tl => Return x + | Betree_List_Nil => Fail_ Failure end . (** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) -Definition betree_list_pop_front_back - (T : Type) (self : Betree_list_t T) : result (Betree_list_t T) := - let ls := mem_replace_fwd (Betree_list_t T) self BetreeListNil in +Definition betree_List_pop_front_back + (T : Type) (self : betree_List_t T) : result (betree_List_t T) := + let ls := core_mem_replace (betree_List_t T) self Betree_List_Nil in match ls with - | BetreeListCons x tl => Return tl - | BetreeListNil => Fail_ Failure + | Betree_List_Cons x tl => Return tl + | Betree_List_Nil => Fail_ Failure end . (** [betree_main::betree::List::{1}::hd]: forward function *) -Definition betree_list_hd_fwd (T : Type) (self : Betree_list_t T) : result T := +Definition betree_List_hd (T : Type) (self : betree_List_t T) : result T := match self with - | BetreeListCons hd l => Return hd - | BetreeListNil => Fail_ Failure + | Betree_List_Cons hd l => Return hd + | Betree_List_Nil => Fail_ Failure end . (** [betree_main::betree::List::{2}::head_has_key]: forward function *) -Definition betree_list_head_has_key_fwd - (T : Type) (self : Betree_list_t (u64 * T)) (key : u64) : result bool := +Definition betree_List_head_has_key + (T : Type) (self : betree_List_t (u64 * T)) (key : u64) : result bool := match self with - | BetreeListCons hd l => let (i, _) := hd in Return (i s= key) - | BetreeListNil => Return false + | Betree_List_Cons hd l => let (i, _) := hd in Return (i s= key) + | Betree_List_Nil => Return false end . (** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -Fixpoint betree_list_partition_at_pivot_fwd - (T : Type) (n : nat) (self : Betree_list_t (u64 * T)) (pivot : u64) : - result ((Betree_list_t (u64 * T)) * (Betree_list_t (u64 * T))) +Fixpoint betree_List_partition_at_pivot + (T : Type) (n : nat) (self : betree_List_t (u64 * T)) (pivot : u64) : + result ((betree_List_t (u64 * T)) * (betree_List_t (u64 * T))) := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => let (i, t) := hd in if i s>= pivot - then Return (BetreeListNil, BetreeListCons (i, t) tl) + then Return (Betree_List_Nil, Betree_List_Cons (i, t) tl) else ( - p <- betree_list_partition_at_pivot_fwd T n0 tl pivot; + p <- betree_List_partition_at_pivot T n0 tl pivot; let (ls0, ls1) := p in let l := ls0 in - Return (BetreeListCons (i, t) l, ls1)) - | BetreeListNil => Return (BetreeListNil, BetreeListNil) + Return (Betree_List_Cons (i, t) l, ls1)) + | Betree_List_Nil => Return (Betree_List_Nil, Betree_List_Nil) end end . (** [betree_main::betree::Leaf::{3}::split]: forward function *) -Definition betree_leaf_split_fwd - (n : nat) (self : Betree_leaf_t) (content : Betree_list_t (u64 * u64)) - (params : Betree_params_t) (node_id_cnt : Betree_node_id_counter_t) +Definition betree_Leaf_split + (n : nat) (self : betree_Leaf_t) (content : betree_List_t (u64 * u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result (state * Betree_internal_t) + result (state * betree_Internal_t) := p <- - betree_list_split_at_fwd (u64 * u64) n content - params.(Betree_params_split_size); + betree_List_split_at (u64 * u64) n content + params.(betree_Params_split_size); let (content0, content1) := p in - p0 <- betree_list_hd_fwd (u64 * u64) content1; + p0 <- betree_List_hd (u64 * u64) content1; let (pivot, _) := p0 in - id0 <- betree_node_id_counter_fresh_id_fwd node_id_cnt; - node_id_cnt0 <- betree_node_id_counter_fresh_id_back node_id_cnt; - id1 <- betree_node_id_counter_fresh_id_fwd node_id_cnt0; - p1 <- betree_store_leaf_node_fwd id0 content0 st; + id0 <- betree_NodeIdCounter_fresh_id node_id_cnt; + node_id_cnt0 <- betree_NodeIdCounter_fresh_id_back node_id_cnt; + id1 <- betree_NodeIdCounter_fresh_id node_id_cnt0; + p1 <- betree_store_leaf_node id0 content0 st; let (st0, _) := p1 in - p2 <- betree_store_leaf_node_fwd id1 content1 st0; + p2 <- betree_store_leaf_node id1 content1 st0; let (st1, _) := p2 in - let n0 := BetreeNodeLeaf + let n0 := Betree_Node_Leaf {| - Betree_leaf_id := id0; - Betree_leaf_size := params.(Betree_params_split_size) + betree_Leaf_id := id0; + betree_Leaf_size := params.(betree_Params_split_size) |} in - let n1 := BetreeNodeLeaf + let n1 := Betree_Node_Leaf {| - Betree_leaf_id := id1; - Betree_leaf_size := params.(Betree_params_split_size) + betree_Leaf_id := id1; + betree_Leaf_size := params.(betree_Params_split_size) |} in - Return (st1, mkBetree_internal_t self.(Betree_leaf_id) pivot n0 n1) + Return (st1, mkbetree_Internal_t self.(betree_Leaf_id) pivot n0 n1) . (** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) -Definition betree_leaf_split_back - (n : nat) (self : Betree_leaf_t) (content : Betree_list_t (u64 * u64)) - (params : Betree_params_t) (node_id_cnt : Betree_node_id_counter_t) +Definition betree_Leaf_split_back + (n : nat) (self : betree_Leaf_t) (content : betree_List_t (u64 * u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result Betree_node_id_counter_t + result betree_NodeIdCounter_t := p <- - betree_list_split_at_fwd (u64 * u64) n content - params.(Betree_params_split_size); + betree_List_split_at (u64 * u64) n content + params.(betree_Params_split_size); let (content0, content1) := p in - _ <- betree_list_hd_fwd (u64 * u64) content1; - id0 <- betree_node_id_counter_fresh_id_fwd node_id_cnt; - node_id_cnt0 <- betree_node_id_counter_fresh_id_back node_id_cnt; - id1 <- betree_node_id_counter_fresh_id_fwd node_id_cnt0; - p0 <- betree_store_leaf_node_fwd id0 content0 st; + _ <- betree_List_hd (u64 * u64) content1; + id0 <- betree_NodeIdCounter_fresh_id node_id_cnt; + node_id_cnt0 <- betree_NodeIdCounter_fresh_id_back node_id_cnt; + id1 <- betree_NodeIdCounter_fresh_id node_id_cnt0; + p0 <- betree_store_leaf_node id0 content0 st; let (st0, _) := p0 in - _ <- betree_store_leaf_node_fwd id1 content1 st0; - betree_node_id_counter_fresh_id_back node_id_cnt0 + _ <- betree_store_leaf_node id1 content1 st0; + betree_NodeIdCounter_fresh_id_back node_id_cnt0 . (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) -Fixpoint betree_node_lookup_first_message_for_key_fwd - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_lookup_first_message_for_key + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons x next_msgs => + | Betree_List_Cons x next_msgs => let (i, m) := x in if i s>= key - then Return (BetreeListCons (i, m) next_msgs) - else betree_node_lookup_first_message_for_key_fwd n0 key next_msgs - | BetreeListNil => Return BetreeListNil + then Return (Betree_List_Cons (i, m) next_msgs) + else betree_Node_lookup_first_message_for_key n0 key next_msgs + | Betree_List_Nil => Return Betree_List_Nil end end . (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) -Fixpoint betree_node_lookup_first_message_for_key_back - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) - (ret : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_lookup_first_message_for_key_back + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) + (ret : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons x next_msgs => + | Betree_List_Cons x next_msgs => let (i, m) := x in if i s>= key then Return ret else ( next_msgs0 <- - betree_node_lookup_first_message_for_key_back n0 key next_msgs ret; - Return (BetreeListCons (i, m) next_msgs0)) - | BetreeListNil => Return ret + betree_Node_lookup_first_message_for_key_back n0 key next_msgs ret; + Return (Betree_List_Cons (i, m) next_msgs0)) + | Betree_List_Nil => Return ret end end . (** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) -Fixpoint betree_node_apply_upserts_fwd - (n : nat) (msgs : Betree_list_t (u64 * Betree_message_t)) (prev : option u64) +Fixpoint betree_Node_apply_upserts + (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (prev : option u64) (key : u64) (st : state) : result (state * u64) := match n with | O => Fail_ OutOfFuel | S n0 => - b <- betree_list_head_has_key_fwd Betree_message_t msgs key; + b <- betree_List_head_has_key betree_Message_t msgs key; if b then ( - msg <- betree_list_pop_front_fwd (u64 * Betree_message_t) msgs; + msg <- betree_List_pop_front (u64 * betree_Message_t) msgs; let (_, m) := msg in match m with - | BetreeMessageInsert i => Fail_ Failure - | BetreeMessageDelete => Fail_ Failure - | BetreeMessageUpsert s => - v <- betree_upsert_update_fwd prev s; - msgs0 <- betree_list_pop_front_back (u64 * Betree_message_t) msgs; - betree_node_apply_upserts_fwd n0 msgs0 (Some v) key st + | Betree_Message_Insert i => Fail_ Failure + | Betree_Message_Delete => Fail_ Failure + | Betree_Message_Upsert s => + v <- betree_upsert_update prev s; + msgs0 <- betree_List_pop_front_back (u64 * betree_Message_t) msgs; + betree_Node_apply_upserts n0 msgs0 (Some v) key st end) else ( - p <- core_option_option_unwrap_fwd u64 prev st; + p <- core_option_Option_unwrap u64 prev st; let (st0, v) := p in _ <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs (key, - BetreeMessageInsert v); + betree_List_push_front (u64 * betree_Message_t) msgs (key, + Betree_Message_Insert v); Return (st0, v)) end . (** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) -Fixpoint betree_node_apply_upserts_back - (n : nat) (msgs : Betree_list_t (u64 * Betree_message_t)) (prev : option u64) +Fixpoint betree_Node_apply_upserts_back + (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (prev : option u64) (key : u64) (st : state) : - result (Betree_list_t (u64 * Betree_message_t)) + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => - b <- betree_list_head_has_key_fwd Betree_message_t msgs key; + b <- betree_List_head_has_key betree_Message_t msgs key; if b then ( - msg <- betree_list_pop_front_fwd (u64 * Betree_message_t) msgs; + msg <- betree_List_pop_front (u64 * betree_Message_t) msgs; let (_, m) := msg in match m with - | BetreeMessageInsert i => Fail_ Failure - | BetreeMessageDelete => Fail_ Failure - | BetreeMessageUpsert s => - v <- betree_upsert_update_fwd prev s; - msgs0 <- betree_list_pop_front_back (u64 * Betree_message_t) msgs; - betree_node_apply_upserts_back n0 msgs0 (Some v) key st + | Betree_Message_Insert i => Fail_ Failure + | Betree_Message_Delete => Fail_ Failure + | Betree_Message_Upsert s => + v <- betree_upsert_update prev s; + msgs0 <- betree_List_pop_front_back (u64 * betree_Message_t) msgs; + betree_Node_apply_upserts_back n0 msgs0 (Some v) key st end) else ( - p <- core_option_option_unwrap_fwd u64 prev st; + p <- core_option_Option_unwrap u64 prev st; let (_, v) := p in - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs (key, - BetreeMessageInsert v)) + betree_List_push_front (u64 * betree_Message_t) msgs (key, + Betree_Message_Insert v)) end . (** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) -Fixpoint betree_node_lookup_in_bindings_fwd - (n : nat) (key : u64) (bindings : Betree_list_t (u64 * u64)) : +Fixpoint betree_Node_lookup_in_bindings + (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : result (option u64) := match n with | O => Fail_ OutOfFuel | S n0 => match bindings with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => let (i, i0) := hd in if i s= key then Return (Some i0) else if i s> key then Return None - else betree_node_lookup_in_bindings_fwd n0 key tl - | BetreeListNil => Return None + else betree_Node_lookup_in_bindings n0 key tl + | Betree_List_Nil => Return None end end . (** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) -Fixpoint betree_internal_lookup_in_children_fwd - (n : nat) (self : Betree_internal_t) (key : u64) (st : state) : +Fixpoint betree_Internal_lookup_in_children + (n : nat) (self : betree_Internal_t) (key : u64) (st : state) : result (state * (option u64)) := match n with | O => Fail_ OutOfFuel | S n0 => - if key s< self.(Betree_internal_pivot) - then betree_node_lookup_fwd n0 self.(Betree_internal_left) key st - else betree_node_lookup_fwd n0 self.(Betree_internal_right) key st + if key s< self.(betree_Internal_pivot) + then betree_Node_lookup n0 self.(betree_Internal_left) key st + else betree_Node_lookup n0 self.(betree_Internal_right) key st end (** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) -with betree_internal_lookup_in_children_back - (n : nat) (self : Betree_internal_t) (key : u64) (st : state) : - result Betree_internal_t +with betree_Internal_lookup_in_children_back + (n : nat) (self : betree_Internal_t) (key : u64) (st : state) : + result betree_Internal_t := match n with | O => Fail_ OutOfFuel | S n0 => - if key s< self.(Betree_internal_pivot) + if key s< self.(betree_Internal_pivot) then ( - n1 <- betree_node_lookup_back n0 self.(Betree_internal_left) key st; - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) n1 self.(Betree_internal_right))) + n1 <- betree_Node_lookup_back n0 self.(betree_Internal_left) key st; + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) n1 self.(betree_Internal_right))) else ( - n1 <- betree_node_lookup_back n0 self.(Betree_internal_right) key st; - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) self.(Betree_internal_left) n1)) + n1 <- betree_Node_lookup_back n0 self.(betree_Internal_right) key st; + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) self.(betree_Internal_left) n1)) end (** [betree_main::betree::Node::{5}::lookup]: forward function *) -with betree_node_lookup_fwd - (n : nat) (self : Betree_node_t) (key : u64) (st : state) : +with betree_Node_lookup + (n : nat) (self : betree_Node_t) (key : u64) (st : state) : result (state * (option u64)) := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeNodeInternal node => - p <- betree_load_internal_node_fwd node.(Betree_internal_id) st; + | Betree_Node_Internal node => + p <- betree_load_internal_node node.(betree_Internal_id) st; let (st0, msgs) := p in - pending <- betree_node_lookup_first_message_for_key_fwd n0 key msgs; + pending <- betree_Node_lookup_first_message_for_key n0 key msgs; match pending with - | BetreeListCons p0 l => + | Betree_List_Cons p0 l => let (k, msg) := p0 in if k s<> key then ( - p1 <- betree_internal_lookup_in_children_fwd n0 node key st0; - let (st1, opt) := p1 in + p1 <- betree_Internal_lookup_in_children n0 node key st0; + let (st1, o) := p1 in _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, msg) l); - Return (st1, opt)) + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, msg) l); + Return (st1, o)) else match msg with - | BetreeMessageInsert v => + | Betree_Message_Insert v => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, BetreeMessageInsert v) l); + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l); Return (st0, Some v) - | BetreeMessageDelete => + | Betree_Message_Delete => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, BetreeMessageDelete) l); + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l); Return (st0, None) - | BetreeMessageUpsert ufs => - p1 <- betree_internal_lookup_in_children_fwd n0 node key st0; + | Betree_Message_Upsert ufs => + p1 <- betree_Internal_lookup_in_children n0 node key st0; let (st1, v) := p1 in p2 <- - betree_node_apply_upserts_fwd n0 (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1; + betree_Node_apply_upserts n0 (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1; let (st2, v0) := p2 in - node0 <- betree_internal_lookup_in_children_back n0 node key st0; + node0 <- betree_Internal_lookup_in_children_back n0 node key st0; pending0 <- - betree_node_apply_upserts_back n0 (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1; + betree_Node_apply_upserts_back n0 (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1; msgs0 <- - betree_node_lookup_first_message_for_key_back n0 key msgs + betree_Node_lookup_first_message_for_key_back n0 key msgs pending0; p3 <- - betree_store_internal_node_fwd node0.(Betree_internal_id) msgs0 - st2; + betree_store_internal_node node0.(betree_Internal_id) msgs0 st2; let (st3, _) := p3 in Return (st3, Some v0) end - | BetreeListNil => - p0 <- betree_internal_lookup_in_children_fwd n0 node key st0; - let (st1, opt) := p0 in + | Betree_List_Nil => + p0 <- betree_Internal_lookup_in_children n0 node key st0; + let (st1, o) := p0 in _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - BetreeListNil; - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back n0 key msgs + Betree_List_Nil; + Return (st1, o) end - | BetreeNodeLeaf node => - p <- betree_load_leaf_node_fwd node.(Betree_leaf_id) st; + | Betree_Node_Leaf node => + p <- betree_load_leaf_node node.(betree_Leaf_id) st; let (st0, bindings) := p in - opt <- betree_node_lookup_in_bindings_fwd n0 key bindings; - Return (st0, opt) + o <- betree_Node_lookup_in_bindings n0 key bindings; + Return (st0, o) end end (** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) -with betree_node_lookup_back - (n : nat) (self : Betree_node_t) (key : u64) (st : state) : - result Betree_node_t +with betree_Node_lookup_back + (n : nat) (self : betree_Node_t) (key : u64) (st : state) : + result betree_Node_t := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeNodeInternal node => - p <- betree_load_internal_node_fwd node.(Betree_internal_id) st; + | Betree_Node_Internal node => + p <- betree_load_internal_node node.(betree_Internal_id) st; let (st0, msgs) := p in - pending <- betree_node_lookup_first_message_for_key_fwd n0 key msgs; + pending <- betree_Node_lookup_first_message_for_key n0 key msgs; match pending with - | BetreeListCons p0 l => + | Betree_List_Cons p0 l => let (k, msg) := p0 in if k s<> key then ( _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, msg) l); - node0 <- betree_internal_lookup_in_children_back n0 node key st0; - Return (BetreeNodeInternal node0)) + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, msg) l); + node0 <- betree_Internal_lookup_in_children_back n0 node key st0; + Return (Betree_Node_Internal node0)) else match msg with - | BetreeMessageInsert v => + | Betree_Message_Insert v => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, BetreeMessageInsert v) l); - Return (BetreeNodeInternal node) - | BetreeMessageDelete => + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l); + Return (Betree_Node_Internal node) + | Betree_Message_Delete => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, BetreeMessageDelete) l); - Return (BetreeNodeInternal node) - | BetreeMessageUpsert ufs => - p1 <- betree_internal_lookup_in_children_fwd n0 node key st0; + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l); + Return (Betree_Node_Internal node) + | Betree_Message_Upsert ufs => + p1 <- betree_Internal_lookup_in_children n0 node key st0; let (st1, v) := p1 in p2 <- - betree_node_apply_upserts_fwd n0 (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1; + betree_Node_apply_upserts n0 (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1; let (st2, _) := p2 in - node0 <- betree_internal_lookup_in_children_back n0 node key st0; + node0 <- betree_Internal_lookup_in_children_back n0 node key st0; pending0 <- - betree_node_apply_upserts_back n0 (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1; + betree_Node_apply_upserts_back n0 (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1; msgs0 <- - betree_node_lookup_first_message_for_key_back n0 key msgs + betree_Node_lookup_first_message_for_key_back n0 key msgs pending0; _ <- - betree_store_internal_node_fwd node0.(Betree_internal_id) msgs0 - st2; - Return (BetreeNodeInternal node0) + betree_store_internal_node node0.(betree_Internal_id) msgs0 st2; + Return (Betree_Node_Internal node0) end - | BetreeListNil => + | Betree_List_Nil => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - BetreeListNil; - node0 <- betree_internal_lookup_in_children_back n0 node key st0; - Return (BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back n0 key msgs + Betree_List_Nil; + node0 <- betree_Internal_lookup_in_children_back n0 node key st0; + Return (Betree_Node_Internal node0) end - | BetreeNodeLeaf node => - p <- betree_load_leaf_node_fwd node.(Betree_leaf_id) st; + | Betree_Node_Leaf node => + p <- betree_load_leaf_node node.(betree_Leaf_id) st; let (_, bindings) := p in - _ <- betree_node_lookup_in_bindings_fwd n0 key bindings; - Return (BetreeNodeLeaf node) + _ <- betree_Node_lookup_in_bindings n0 key bindings; + Return (Betree_Node_Leaf node) end end . (** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint betree_node_filter_messages_for_key_fwd_back - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_filter_messages_for_key + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons p l => + | Betree_List_Cons p l => let (k, m) := p in if k s= key then ( msgs0 <- - betree_list_pop_front_back (u64 * Betree_message_t) (BetreeListCons + betree_List_pop_front_back (u64 * betree_Message_t) (Betree_List_Cons (k, m) l); - betree_node_filter_messages_for_key_fwd_back n0 key msgs0) - else Return (BetreeListCons (k, m) l) - | BetreeListNil => Return BetreeListNil + betree_Node_filter_messages_for_key n0 key msgs0) + else Return (Betree_List_Cons (k, m) l) + | Betree_List_Nil => Return Betree_List_Nil end end . (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) -Fixpoint betree_node_lookup_first_message_after_key_fwd - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_lookup_first_message_after_key + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons p next_msgs => + | Betree_List_Cons p next_msgs => let (k, m) := p in if k s= key - then betree_node_lookup_first_message_after_key_fwd n0 key next_msgs - else Return (BetreeListCons (k, m) next_msgs) - | BetreeListNil => Return BetreeListNil + then betree_Node_lookup_first_message_after_key n0 key next_msgs + else Return (Betree_List_Cons (k, m) next_msgs) + | Betree_List_Nil => Return Betree_List_Nil end end . (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) -Fixpoint betree_node_lookup_first_message_after_key_back - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) - (ret : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_lookup_first_message_after_key_back + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) + (ret : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons p next_msgs => + | Betree_List_Cons p next_msgs => let (k, m) := p in if k s= key then ( next_msgs0 <- - betree_node_lookup_first_message_after_key_back n0 key next_msgs ret; - Return (BetreeListCons (k, m) next_msgs0)) + betree_Node_lookup_first_message_after_key_back n0 key next_msgs ret; + Return (Betree_List_Cons (k, m) next_msgs0)) else Return ret - | BetreeListNil => Return ret + | Betree_List_Nil => Return ret end end . (** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition betree_node_apply_to_internal_fwd_back - (n : nat) (msgs : Betree_list_t (u64 * Betree_message_t)) (key : u64) - (new_msg : Betree_message_t) : - result (Betree_list_t (u64 * Betree_message_t)) +Definition betree_Node_apply_to_internal + (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 * betree_Message_t)) := - msgs0 <- betree_node_lookup_first_message_for_key_fwd n key msgs; - b <- betree_list_head_has_key_fwd Betree_message_t msgs0 key; + msgs0 <- betree_Node_lookup_first_message_for_key n key msgs; + b <- betree_List_head_has_key betree_Message_t msgs0 key; if b then match new_msg with - | BetreeMessageInsert i => - msgs1 <- betree_node_filter_messages_for_key_fwd_back n key msgs0; + | Betree_Message_Insert i => + msgs1 <- betree_Node_filter_messages_for_key n key msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageInsert i); - betree_node_lookup_first_message_for_key_back n key msgs msgs2 - | BetreeMessageDelete => - msgs1 <- betree_node_filter_messages_for_key_fwd_back n key msgs0; + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Insert i); + betree_Node_lookup_first_message_for_key_back n key msgs msgs2 + | Betree_Message_Delete => + msgs1 <- betree_Node_filter_messages_for_key n key msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageDelete); - betree_node_lookup_first_message_for_key_back n key msgs msgs2 - | BetreeMessageUpsert s => - p <- betree_list_hd_fwd (u64 * Betree_message_t) msgs0; + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Delete); + betree_Node_lookup_first_message_for_key_back n key msgs msgs2 + | Betree_Message_Upsert s => + p <- betree_List_hd (u64 * betree_Message_t) msgs0; let (_, m) := p in match m with - | BetreeMessageInsert prev => - v <- betree_upsert_update_fwd (Some prev) s; - msgs1 <- betree_list_pop_front_back (u64 * Betree_message_t) msgs0; + | Betree_Message_Insert prev => + v <- betree_upsert_update (Some prev) s; + msgs1 <- betree_List_pop_front_back (u64 * betree_Message_t) msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageInsert v); - betree_node_lookup_first_message_for_key_back n key msgs msgs2 - | BetreeMessageDelete => - v <- betree_upsert_update_fwd None s; - msgs1 <- betree_list_pop_front_back (u64 * Betree_message_t) msgs0; + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Insert v); + betree_Node_lookup_first_message_for_key_back n key msgs msgs2 + | Betree_Message_Delete => + v <- betree_upsert_update None s; + msgs1 <- betree_List_pop_front_back (u64 * betree_Message_t) msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageInsert v); - betree_node_lookup_first_message_for_key_back n key msgs msgs2 - | BetreeMessageUpsert ufs => - msgs1 <- betree_node_lookup_first_message_after_key_fwd n key msgs0; + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Insert v); + betree_Node_lookup_first_message_for_key_back n key msgs msgs2 + | Betree_Message_Upsert ufs => + msgs1 <- betree_Node_lookup_first_message_after_key n key msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageUpsert s); + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Upsert s); msgs3 <- - betree_node_lookup_first_message_after_key_back n key msgs0 msgs2; - betree_node_lookup_first_message_for_key_back n key msgs msgs3 + betree_Node_lookup_first_message_after_key_back n key msgs0 msgs2; + betree_Node_lookup_first_message_for_key_back n key msgs msgs3 end end else ( msgs1 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs0 (key, - new_msg); - betree_node_lookup_first_message_for_key_back n key msgs msgs1) + betree_List_push_front (u64 * betree_Message_t) msgs0 (key, new_msg); + betree_Node_lookup_first_message_for_key_back n key msgs msgs1) . (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint betree_node_apply_messages_to_internal_fwd_back - (n : nat) (msgs : Betree_list_t (u64 * Betree_message_t)) - (new_msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_apply_messages_to_internal + (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) + (new_msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match new_msgs with - | BetreeListCons new_msg new_msgs_tl => + | Betree_List_Cons new_msg new_msgs_tl => let (i, m) := new_msg in - msgs0 <- betree_node_apply_to_internal_fwd_back n0 msgs i m; - betree_node_apply_messages_to_internal_fwd_back n0 msgs0 new_msgs_tl - | BetreeListNil => Return msgs + msgs0 <- betree_Node_apply_to_internal n0 msgs i m; + betree_Node_apply_messages_to_internal n0 msgs0 new_msgs_tl + | Betree_List_Nil => Return msgs end end . (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) -Fixpoint betree_node_lookup_mut_in_bindings_fwd - (n : nat) (key : u64) (bindings : Betree_list_t (u64 * u64)) : - result (Betree_list_t (u64 * u64)) +Fixpoint betree_Node_lookup_mut_in_bindings + (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : + result (betree_List_t (u64 * u64)) := match n with | O => Fail_ OutOfFuel | S n0 => match bindings with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => let (i, i0) := hd in if i s>= key - then Return (BetreeListCons (i, i0) tl) - else betree_node_lookup_mut_in_bindings_fwd n0 key tl - | BetreeListNil => Return BetreeListNil + then Return (Betree_List_Cons (i, i0) tl) + else betree_Node_lookup_mut_in_bindings n0 key tl + | Betree_List_Nil => Return Betree_List_Nil end end . (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) -Fixpoint betree_node_lookup_mut_in_bindings_back - (n : nat) (key : u64) (bindings : Betree_list_t (u64 * u64)) - (ret : Betree_list_t (u64 * u64)) : - result (Betree_list_t (u64 * u64)) +Fixpoint betree_Node_lookup_mut_in_bindings_back + (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) + (ret : betree_List_t (u64 * u64)) : + result (betree_List_t (u64 * u64)) := match n with | O => Fail_ OutOfFuel | S n0 => match bindings with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => let (i, i0) := hd in if i s>= key then Return ret else ( - tl0 <- betree_node_lookup_mut_in_bindings_back n0 key tl ret; - Return (BetreeListCons (i, i0) tl0)) - | BetreeListNil => Return ret + tl0 <- betree_Node_lookup_mut_in_bindings_back n0 key tl ret; + Return (Betree_List_Cons (i, i0) tl0)) + | Betree_List_Nil => Return ret end end . (** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition betree_node_apply_to_leaf_fwd_back - (n : nat) (bindings : Betree_list_t (u64 * u64)) (key : u64) - (new_msg : Betree_message_t) : - result (Betree_list_t (u64 * u64)) +Definition betree_Node_apply_to_leaf + (n : nat) (bindings : betree_List_t (u64 * u64)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 * u64)) := - bindings0 <- betree_node_lookup_mut_in_bindings_fwd n key bindings; - b <- betree_list_head_has_key_fwd u64 bindings0 key; + bindings0 <- betree_Node_lookup_mut_in_bindings n key bindings; + b <- betree_List_head_has_key u64 bindings0 key; if b then ( - hd <- betree_list_pop_front_fwd (u64 * u64) bindings0; + hd <- betree_List_pop_front (u64 * u64) bindings0; match new_msg with - | BetreeMessageInsert v => - bindings1 <- betree_list_pop_front_back (u64 * u64) bindings0; - bindings2 <- - betree_list_push_front_fwd_back (u64 * u64) bindings1 (key, v); - betree_node_lookup_mut_in_bindings_back n key bindings bindings2 - | BetreeMessageDelete => - bindings1 <- betree_list_pop_front_back (u64 * u64) bindings0; - betree_node_lookup_mut_in_bindings_back n key bindings bindings1 - | BetreeMessageUpsert s => + | Betree_Message_Insert v => + bindings1 <- betree_List_pop_front_back (u64 * u64) bindings0; + bindings2 <- betree_List_push_front (u64 * u64) bindings1 (key, v); + betree_Node_lookup_mut_in_bindings_back n key bindings bindings2 + | Betree_Message_Delete => + bindings1 <- betree_List_pop_front_back (u64 * u64) bindings0; + betree_Node_lookup_mut_in_bindings_back n key bindings bindings1 + | Betree_Message_Upsert s => let (_, i) := hd in - v <- betree_upsert_update_fwd (Some i) s; - bindings1 <- betree_list_pop_front_back (u64 * u64) bindings0; - bindings2 <- - betree_list_push_front_fwd_back (u64 * u64) bindings1 (key, v); - betree_node_lookup_mut_in_bindings_back n key bindings bindings2 + v <- betree_upsert_update (Some i) s; + bindings1 <- betree_List_pop_front_back (u64 * u64) bindings0; + bindings2 <- betree_List_push_front (u64 * u64) bindings1 (key, v); + betree_Node_lookup_mut_in_bindings_back n key bindings bindings2 end) else match new_msg with - | BetreeMessageInsert v => - bindings1 <- - betree_list_push_front_fwd_back (u64 * u64) bindings0 (key, v); - betree_node_lookup_mut_in_bindings_back n key bindings bindings1 - | BetreeMessageDelete => - betree_node_lookup_mut_in_bindings_back n key bindings bindings0 - | BetreeMessageUpsert s => - v <- betree_upsert_update_fwd None s; - bindings1 <- - betree_list_push_front_fwd_back (u64 * u64) bindings0 (key, v); - betree_node_lookup_mut_in_bindings_back n key bindings bindings1 + | Betree_Message_Insert v => + bindings1 <- betree_List_push_front (u64 * u64) bindings0 (key, v); + betree_Node_lookup_mut_in_bindings_back n key bindings bindings1 + | Betree_Message_Delete => + betree_Node_lookup_mut_in_bindings_back n key bindings bindings0 + | Betree_Message_Upsert s => + v <- betree_upsert_update None s; + bindings1 <- betree_List_push_front (u64 * u64) bindings0 (key, v); + betree_Node_lookup_mut_in_bindings_back n key bindings bindings1 end . (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint betree_node_apply_messages_to_leaf_fwd_back - (n : nat) (bindings : Betree_list_t (u64 * u64)) - (new_msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * u64)) +Fixpoint betree_Node_apply_messages_to_leaf + (n : nat) (bindings : betree_List_t (u64 * u64)) + (new_msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * u64)) := match n with | O => Fail_ OutOfFuel | S n0 => match new_msgs with - | BetreeListCons new_msg new_msgs_tl => + | Betree_List_Cons new_msg new_msgs_tl => let (i, m) := new_msg in - bindings0 <- betree_node_apply_to_leaf_fwd_back n0 bindings i m; - betree_node_apply_messages_to_leaf_fwd_back n0 bindings0 new_msgs_tl - | BetreeListNil => Return bindings + bindings0 <- betree_Node_apply_to_leaf n0 bindings i m; + betree_Node_apply_messages_to_leaf n0 bindings0 new_msgs_tl + | Betree_List_Nil => Return bindings end end . (** [betree_main::betree::Internal::{4}::flush]: forward function *) -Fixpoint betree_internal_flush_fwd - (n : nat) (self : Betree_internal_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) - (content : Betree_list_t (u64 * Betree_message_t)) (st : state) : - result (state * (Betree_list_t (u64 * Betree_message_t))) +Fixpoint betree_Internal_flush + (n : nat) (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 * betree_Message_t)) (st : state) : + result (state * (betree_List_t (u64 * betree_Message_t))) := match n with | O => Fail_ OutOfFuel | S n0 => p <- - betree_list_partition_at_pivot_fwd Betree_message_t n0 content - self.(Betree_internal_pivot); + betree_List_partition_at_pivot betree_Message_t n0 content + self.(betree_Internal_pivot); let (msgs_left, msgs_right) := p in - len_left <- betree_list_len_fwd (u64 * Betree_message_t) n0 msgs_left; - if len_left s>= params.(Betree_params_min_flush_size) + len_left <- betree_List_len (u64 * betree_Message_t) n0 msgs_left; + if len_left s>= params.(betree_Params_min_flush_size) then ( p0 <- - betree_node_apply_messages_fwd n0 self.(Betree_internal_left) params + betree_Node_apply_messages n0 self.(betree_Internal_left) params node_id_cnt msgs_left st; let (st0, _) := p0 in p1 <- - betree_node_apply_messages_back n0 self.(Betree_internal_left) params + betree_Node_apply_messages_back n0 self.(betree_Internal_left) params node_id_cnt msgs_left st; let (_, node_id_cnt0) := p1 in - len_right <- betree_list_len_fwd (u64 * Betree_message_t) n0 msgs_right; - if len_right s>= params.(Betree_params_min_flush_size) + len_right <- betree_List_len (u64 * betree_Message_t) n0 msgs_right; + if len_right s>= params.(betree_Params_min_flush_size) then ( p2 <- - betree_node_apply_messages_fwd n0 self.(Betree_internal_right) params + betree_Node_apply_messages n0 self.(betree_Internal_right) params node_id_cnt0 msgs_right st0; let (st1, _) := p2 in _ <- - betree_node_apply_messages_back n0 self.(Betree_internal_right) + betree_Node_apply_messages_back n0 self.(betree_Internal_right) params node_id_cnt0 msgs_right st0; - Return (st1, BetreeListNil)) + Return (st1, Betree_List_Nil)) else Return (st0, msgs_right)) else ( p0 <- - betree_node_apply_messages_fwd n0 self.(Betree_internal_right) params + betree_Node_apply_messages n0 self.(betree_Internal_right) params node_id_cnt msgs_right st; let (st0, _) := p0 in _ <- - betree_node_apply_messages_back n0 self.(Betree_internal_right) params + betree_Node_apply_messages_back n0 self.(betree_Internal_right) params node_id_cnt msgs_right st; Return (st0, msgs_left)) end (** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) -with betree_internal_flush_back - (n : nat) (self : Betree_internal_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) - (content : Betree_list_t (u64 * Betree_message_t)) (st : state) : - result (Betree_internal_t * Betree_node_id_counter_t) +with betree_Internal_flush_back + (n : nat) (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 * betree_Message_t)) (st : state) : + result (betree_Internal_t * betree_NodeIdCounter_t) := match n with | O => Fail_ OutOfFuel | S n0 => p <- - betree_list_partition_at_pivot_fwd Betree_message_t n0 content - self.(Betree_internal_pivot); + betree_List_partition_at_pivot betree_Message_t n0 content + self.(betree_Internal_pivot); let (msgs_left, msgs_right) := p in - len_left <- betree_list_len_fwd (u64 * Betree_message_t) n0 msgs_left; - if len_left s>= params.(Betree_params_min_flush_size) + len_left <- betree_List_len (u64 * betree_Message_t) n0 msgs_left; + if len_left s>= params.(betree_Params_min_flush_size) then ( p0 <- - betree_node_apply_messages_fwd n0 self.(Betree_internal_left) params + betree_Node_apply_messages n0 self.(betree_Internal_left) params node_id_cnt msgs_left st; let (st0, _) := p0 in p1 <- - betree_node_apply_messages_back n0 self.(Betree_internal_left) params + betree_Node_apply_messages_back n0 self.(betree_Internal_left) params node_id_cnt msgs_left st; let (n1, node_id_cnt0) := p1 in - len_right <- betree_list_len_fwd (u64 * Betree_message_t) n0 msgs_right; - if len_right s>= params.(Betree_params_min_flush_size) + len_right <- betree_List_len (u64 * betree_Message_t) n0 msgs_right; + if len_right s>= params.(betree_Params_min_flush_size) then ( p2 <- - betree_node_apply_messages_back n0 self.(Betree_internal_right) + betree_Node_apply_messages_back n0 self.(betree_Internal_right) params node_id_cnt0 msgs_right st0; let (n2, node_id_cnt1) := p2 in - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) n1 n2, node_id_cnt1)) + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) n1 n2, node_id_cnt1)) else - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) n1 self.(Betree_internal_right), + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) n1 self.(betree_Internal_right), node_id_cnt0)) else ( p0 <- - betree_node_apply_messages_back n0 self.(Betree_internal_right) params + betree_Node_apply_messages_back n0 self.(betree_Internal_right) params node_id_cnt msgs_right st; let (n1, node_id_cnt0) := p0 in - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) self.(Betree_internal_left) n1, + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) self.(betree_Internal_left) n1, node_id_cnt0)) end (** [betree_main::betree::Node::{5}::apply_messages]: forward function *) -with betree_node_apply_messages_fwd - (n : nat) (self : Betree_node_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) - (msgs : Betree_list_t (u64 * Betree_message_t)) (st : state) : +with betree_Node_apply_messages + (n : nat) (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 * betree_Message_t)) (st : state) : result (state * unit) := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeNodeInternal node => - p <- betree_load_internal_node_fwd node.(Betree_internal_id) st; + | Betree_Node_Internal node => + p <- betree_load_internal_node node.(betree_Internal_id) st; let (st0, content) := p in - content0 <- - betree_node_apply_messages_to_internal_fwd_back n0 content msgs; - num_msgs <- betree_list_len_fwd (u64 * Betree_message_t) n0 content0; - if num_msgs s>= params.(Betree_params_min_flush_size) + content0 <- betree_Node_apply_messages_to_internal n0 content msgs; + num_msgs <- betree_List_len (u64 * betree_Message_t) n0 content0; + if num_msgs s>= params.(betree_Params_min_flush_size) then ( - p0 <- - betree_internal_flush_fwd n0 node params node_id_cnt content0 st0; + p0 <- betree_Internal_flush n0 node params node_id_cnt content0 st0; let (st1, content1) := p0 in p1 <- - betree_internal_flush_back n0 node params node_id_cnt content0 st0; + betree_Internal_flush_back n0 node params node_id_cnt content0 st0; let (node0, _) := p1 in p2 <- - betree_store_internal_node_fwd node0.(Betree_internal_id) content1 - st1; + betree_store_internal_node node0.(betree_Internal_id) content1 st1; let (st2, _) := p2 in Return (st2, tt)) else ( p0 <- - betree_store_internal_node_fwd node.(Betree_internal_id) content0 st0; + betree_store_internal_node node.(betree_Internal_id) content0 st0; let (st1, _) := p0 in Return (st1, tt)) - | BetreeNodeLeaf node => - p <- betree_load_leaf_node_fwd node.(Betree_leaf_id) st; + | Betree_Node_Leaf node => + p <- betree_load_leaf_node node.(betree_Leaf_id) st; let (st0, content) := p in - content0 <- betree_node_apply_messages_to_leaf_fwd_back n0 content msgs; - len <- betree_list_len_fwd (u64 * u64) n0 content0; - i <- u64_mul 2%u64 params.(Betree_params_split_size); + content0 <- betree_Node_apply_messages_to_leaf n0 content msgs; + len <- betree_List_len (u64 * u64) n0 content0; + i <- u64_mul 2%u64 params.(betree_Params_split_size); if len s>= i then ( - p0 <- betree_leaf_split_fwd n0 node content0 params node_id_cnt st0; + p0 <- betree_Leaf_split n0 node content0 params node_id_cnt st0; let (st1, _) := p0 in - p1 <- - betree_store_leaf_node_fwd node.(Betree_leaf_id) BetreeListNil st1; + p1 <- betree_store_leaf_node node.(betree_Leaf_id) Betree_List_Nil st1; let (st2, _) := p1 in Return (st2, tt)) else ( - p0 <- betree_store_leaf_node_fwd node.(Betree_leaf_id) content0 st0; + p0 <- betree_store_leaf_node node.(betree_Leaf_id) content0 st0; let (st1, _) := p0 in Return (st1, tt)) end end (** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) -with betree_node_apply_messages_back - (n : nat) (self : Betree_node_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) - (msgs : Betree_list_t (u64 * Betree_message_t)) (st : state) : - result (Betree_node_t * Betree_node_id_counter_t) +with betree_Node_apply_messages_back + (n : nat) (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 * betree_Message_t)) (st : state) : + result (betree_Node_t * betree_NodeIdCounter_t) := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeNodeInternal node => - p <- betree_load_internal_node_fwd node.(Betree_internal_id) st; + | Betree_Node_Internal node => + p <- betree_load_internal_node node.(betree_Internal_id) st; let (st0, content) := p in - content0 <- - betree_node_apply_messages_to_internal_fwd_back n0 content msgs; - num_msgs <- betree_list_len_fwd (u64 * Betree_message_t) n0 content0; - if num_msgs s>= params.(Betree_params_min_flush_size) + content0 <- betree_Node_apply_messages_to_internal n0 content msgs; + num_msgs <- betree_List_len (u64 * betree_Message_t) n0 content0; + if num_msgs s>= params.(betree_Params_min_flush_size) then ( - p0 <- - betree_internal_flush_fwd n0 node params node_id_cnt content0 st0; + p0 <- betree_Internal_flush n0 node params node_id_cnt content0 st0; let (st1, content1) := p0 in p1 <- - betree_internal_flush_back n0 node params node_id_cnt content0 st0; + betree_Internal_flush_back n0 node params node_id_cnt content0 st0; let (node0, node_id_cnt0) := p1 in _ <- - betree_store_internal_node_fwd node0.(Betree_internal_id) content1 - st1; - Return (BetreeNodeInternal node0, node_id_cnt0)) + betree_store_internal_node node0.(betree_Internal_id) content1 st1; + Return (Betree_Node_Internal node0, node_id_cnt0)) else ( - _ <- - betree_store_internal_node_fwd node.(Betree_internal_id) content0 st0; - Return (BetreeNodeInternal node, node_id_cnt)) - | BetreeNodeLeaf node => - p <- betree_load_leaf_node_fwd node.(Betree_leaf_id) st; + _ <- betree_store_internal_node node.(betree_Internal_id) content0 st0; + Return (Betree_Node_Internal node, node_id_cnt)) + | Betree_Node_Leaf node => + p <- betree_load_leaf_node node.(betree_Leaf_id) st; let (st0, content) := p in - content0 <- betree_node_apply_messages_to_leaf_fwd_back n0 content msgs; - len <- betree_list_len_fwd (u64 * u64) n0 content0; - i <- u64_mul 2%u64 params.(Betree_params_split_size); + content0 <- betree_Node_apply_messages_to_leaf n0 content msgs; + len <- betree_List_len (u64 * u64) n0 content0; + i <- u64_mul 2%u64 params.(betree_Params_split_size); if len s>= i then ( - p0 <- betree_leaf_split_fwd n0 node content0 params node_id_cnt st0; + p0 <- betree_Leaf_split n0 node content0 params node_id_cnt st0; let (st1, new_node) := p0 in - _ <- - betree_store_leaf_node_fwd node.(Betree_leaf_id) BetreeListNil st1; + _ <- betree_store_leaf_node node.(betree_Leaf_id) Betree_List_Nil st1; node_id_cnt0 <- - betree_leaf_split_back n0 node content0 params node_id_cnt st0; - Return (BetreeNodeInternal new_node, node_id_cnt0)) + betree_Leaf_split_back n0 node content0 params node_id_cnt st0; + Return (Betree_Node_Internal new_node, node_id_cnt0)) else ( - _ <- betree_store_leaf_node_fwd node.(Betree_leaf_id) content0 st0; - Return (BetreeNodeLeaf - {| Betree_leaf_id := node.(Betree_leaf_id); Betree_leaf_size := len + _ <- betree_store_leaf_node node.(betree_Leaf_id) content0 st0; + Return (Betree_Node_Leaf + {| betree_Leaf_id := node.(betree_Leaf_id); betree_Leaf_size := len |}, node_id_cnt)) end end . (** [betree_main::betree::Node::{5}::apply]: forward function *) -Definition betree_node_apply_fwd - (n : nat) (self : Betree_node_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) (key : u64) - (new_msg : Betree_message_t) (st : state) : +Definition betree_Node_apply + (n : nat) (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : result (state * unit) := - let l := BetreeListNil in + let l := Betree_List_Nil in p <- - betree_node_apply_messages_fwd n self params node_id_cnt (BetreeListCons + betree_Node_apply_messages n self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st; let (st0, _) := p in _ <- - betree_node_apply_messages_back n self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back n self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st; Return (st0, tt) . (** [betree_main::betree::Node::{5}::apply]: backward function 0 *) -Definition betree_node_apply_back - (n : nat) (self : Betree_node_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) (key : u64) - (new_msg : Betree_message_t) (st : state) : - result (Betree_node_t * Betree_node_id_counter_t) +Definition betree_Node_apply_back + (n : nat) (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : + result (betree_Node_t * betree_NodeIdCounter_t) := - let l := BetreeListNil in - betree_node_apply_messages_back n self params node_id_cnt (BetreeListCons + let l := Betree_List_Nil in + betree_Node_apply_messages_back n self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st . (** [betree_main::betree::BeTree::{6}::new]: forward function *) -Definition betree_be_tree_new_fwd +Definition betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : - result (state * Betree_be_tree_t) + result (state * betree_BeTree_t) := - node_id_cnt <- betree_node_id_counter_new_fwd; - id <- betree_node_id_counter_fresh_id_fwd node_id_cnt; - p <- betree_store_leaf_node_fwd id BetreeListNil st; + node_id_cnt <- betree_NodeIdCounter_new; + id <- betree_NodeIdCounter_fresh_id node_id_cnt; + p <- betree_store_leaf_node id Betree_List_Nil st; let (st0, _) := p in - node_id_cnt0 <- betree_node_id_counter_fresh_id_back node_id_cnt; + node_id_cnt0 <- betree_NodeIdCounter_fresh_id_back node_id_cnt; Return (st0, {| - Betree_be_tree_params := + betree_BeTree_params := {| - Betree_params_min_flush_size := min_flush_size; - Betree_params_split_size := split_size + betree_Params_min_flush_size := min_flush_size; + betree_Params_split_size := split_size |}; - Betree_be_tree_node_id_cnt := node_id_cnt0; - Betree_be_tree_root := - (BetreeNodeLeaf {| Betree_leaf_id := id; Betree_leaf_size := 0%u64 |}) + betree_BeTree_node_id_cnt := node_id_cnt0; + betree_BeTree_root := + (Betree_Node_Leaf + {| betree_Leaf_id := id; betree_Leaf_size := 0%u64 |}) |}) . (** [betree_main::betree::BeTree::{6}::apply]: forward function *) -Definition betree_be_tree_apply_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) (msg : Betree_message_t) +Definition betree_BeTree_apply + (n : nat) (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state * unit) := p <- - betree_node_apply_fwd n self.(Betree_be_tree_root) - self.(Betree_be_tree_params) self.(Betree_be_tree_node_id_cnt) key msg st; + betree_Node_apply n self.(betree_BeTree_root) self.(betree_BeTree_params) + self.(betree_BeTree_node_id_cnt) key msg st; let (st0, _) := p in _ <- - betree_node_apply_back n self.(Betree_be_tree_root) - self.(Betree_be_tree_params) self.(Betree_be_tree_node_id_cnt) key msg st; + betree_Node_apply_back n self.(betree_BeTree_root) + self.(betree_BeTree_params) self.(betree_BeTree_node_id_cnt) key msg st; Return (st0, tt) . (** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) -Definition betree_be_tree_apply_back - (n : nat) (self : Betree_be_tree_t) (key : u64) (msg : Betree_message_t) +Definition betree_BeTree_apply_back + (n : nat) (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : - result Betree_be_tree_t + result betree_BeTree_t := p <- - betree_node_apply_back n self.(Betree_be_tree_root) - self.(Betree_be_tree_params) self.(Betree_be_tree_node_id_cnt) key msg st; + betree_Node_apply_back n self.(betree_BeTree_root) + self.(betree_BeTree_params) self.(betree_BeTree_node_id_cnt) key msg st; let (n0, nic) := p in Return {| - Betree_be_tree_params := self.(Betree_be_tree_params); - Betree_be_tree_node_id_cnt := nic; - Betree_be_tree_root := n0 + betree_BeTree_params := self.(betree_BeTree_params); + betree_BeTree_node_id_cnt := nic; + betree_BeTree_root := n0 |} . (** [betree_main::betree::BeTree::{6}::insert]: forward function *) -Definition betree_be_tree_insert_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) (value : u64) (st : state) : +Definition betree_BeTree_insert + (n : nat) (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state * unit) := - p <- betree_be_tree_apply_fwd n self key (BetreeMessageInsert value) st; + p <- betree_BeTree_apply n self key (Betree_Message_Insert value) st; let (st0, _) := p in - _ <- betree_be_tree_apply_back n self key (BetreeMessageInsert value) st; + _ <- betree_BeTree_apply_back n self key (Betree_Message_Insert value) st; Return (st0, tt) . (** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) -Definition betree_be_tree_insert_back - (n : nat) (self : Betree_be_tree_t) (key : u64) (value : u64) (st : state) : - result Betree_be_tree_t +Definition betree_BeTree_insert_back + (n : nat) (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : + result betree_BeTree_t := - betree_be_tree_apply_back n self key (BetreeMessageInsert value) st + betree_BeTree_apply_back n self key (Betree_Message_Insert value) st . (** [betree_main::betree::BeTree::{6}::delete]: forward function *) -Definition betree_be_tree_delete_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) (st : state) : +Definition betree_BeTree_delete + (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result (state * unit) := - p <- betree_be_tree_apply_fwd n self key BetreeMessageDelete st; + p <- betree_BeTree_apply n self key Betree_Message_Delete st; let (st0, _) := p in - _ <- betree_be_tree_apply_back n self key BetreeMessageDelete st; + _ <- betree_BeTree_apply_back n self key Betree_Message_Delete st; Return (st0, tt) . (** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) -Definition betree_be_tree_delete_back - (n : nat) (self : Betree_be_tree_t) (key : u64) (st : state) : - result Betree_be_tree_t +Definition betree_BeTree_delete_back + (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : + result betree_BeTree_t := - betree_be_tree_apply_back n self key BetreeMessageDelete st + betree_BeTree_apply_back n self key Betree_Message_Delete st . (** [betree_main::betree::BeTree::{6}::upsert]: forward function *) -Definition betree_be_tree_upsert_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) - (upd : Betree_upsert_fun_state_t) (st : state) : +Definition betree_BeTree_upsert + (n : nat) (self : betree_BeTree_t) (key : u64) + (upd : betree_UpsertFunState_t) (st : state) : result (state * unit) := - p <- betree_be_tree_apply_fwd n self key (BetreeMessageUpsert upd) st; + p <- betree_BeTree_apply n self key (Betree_Message_Upsert upd) st; let (st0, _) := p in - _ <- betree_be_tree_apply_back n self key (BetreeMessageUpsert upd) st; + _ <- betree_BeTree_apply_back n self key (Betree_Message_Upsert upd) st; Return (st0, tt) . (** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) -Definition betree_be_tree_upsert_back - (n : nat) (self : Betree_be_tree_t) (key : u64) - (upd : Betree_upsert_fun_state_t) (st : state) : - result Betree_be_tree_t +Definition betree_BeTree_upsert_back + (n : nat) (self : betree_BeTree_t) (key : u64) + (upd : betree_UpsertFunState_t) (st : state) : + result betree_BeTree_t := - betree_be_tree_apply_back n self key (BetreeMessageUpsert upd) st + betree_BeTree_apply_back n self key (Betree_Message_Upsert upd) st . (** [betree_main::betree::BeTree::{6}::lookup]: forward function *) -Definition betree_be_tree_lookup_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) (st : state) : +Definition betree_BeTree_lookup + (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result (state * (option u64)) := - betree_node_lookup_fwd n self.(Betree_be_tree_root) key st + betree_Node_lookup n self.(betree_BeTree_root) key st . (** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) -Definition betree_be_tree_lookup_back - (n : nat) (self : Betree_be_tree_t) (key : u64) (st : state) : - result Betree_be_tree_t +Definition betree_BeTree_lookup_back + (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : + result betree_BeTree_t := - n0 <- betree_node_lookup_back n self.(Betree_be_tree_root) key st; + n0 <- betree_Node_lookup_back n self.(betree_BeTree_root) key st; Return {| - Betree_be_tree_params := self.(Betree_be_tree_params); - Betree_be_tree_node_id_cnt := self.(Betree_be_tree_node_id_cnt); - Betree_be_tree_root := n0 + betree_BeTree_params := self.(betree_BeTree_params); + betree_BeTree_node_id_cnt := self.(betree_BeTree_node_id_cnt); + betree_BeTree_root := n0 |} . (** [betree_main::main]: forward function *) -Definition main_fwd : result unit := +Definition main : result unit := Return tt. (** Unit test for [betree_main::main] *) -Check (main_fwd )%return. +Check (main )%return. End BetreeMain_Funs . diff --git a/tests/coq/betree/BetreeMain_Opaque.v b/tests/coq/betree/BetreeMain_Opaque.v index ecd81b9d..eade90de 100644 --- a/tests/coq/betree/BetreeMain_Opaque.v +++ b/tests/coq/betree/BetreeMain_Opaque.v @@ -11,29 +11,29 @@ Import BetreeMain_Types. Module BetreeMain_Opaque. (** [betree_main::betree_utils::load_internal_node]: forward function *) -Axiom betree_utils_load_internal_node_fwd - : u64 -> state -> result (state * (Betree_list_t (u64 * Betree_message_t))) +Axiom betree_utils_load_internal_node + : u64 -> state -> result (state * (betree_List_t (u64 * betree_Message_t))) . (** [betree_main::betree_utils::store_internal_node]: forward function *) -Axiom betree_utils_store_internal_node_fwd +Axiom betree_utils_store_internal_node : - u64 -> Betree_list_t (u64 * Betree_message_t) -> state -> result (state * + u64 -> betree_List_t (u64 * betree_Message_t) -> state -> result (state * unit) . (** [betree_main::betree_utils::load_leaf_node]: forward function *) -Axiom betree_utils_load_leaf_node_fwd - : u64 -> state -> result (state * (Betree_list_t (u64 * u64))) +Axiom betree_utils_load_leaf_node + : u64 -> state -> result (state * (betree_List_t (u64 * u64))) . (** [betree_main::betree_utils::store_leaf_node]: forward function *) -Axiom betree_utils_store_leaf_node_fwd - : u64 -> Betree_list_t (u64 * u64) -> state -> result (state * unit) +Axiom betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 * u64) -> state -> result (state * unit) . (** [core::option::Option::{0}::unwrap]: forward function *) -Axiom core_option_option_unwrap_fwd : +Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . diff --git a/tests/coq/betree/BetreeMain_Types.v b/tests/coq/betree/BetreeMain_Types.v index 4a4e75aa..933a670c 100644 --- a/tests/coq/betree/BetreeMain_Types.v +++ b/tests/coq/betree/BetreeMain_Types.v @@ -9,98 +9,98 @@ Local Open Scope Primitives_scope. Module BetreeMain_Types. (** [betree_main::betree::List] *) -Inductive Betree_list_t (T : Type) := -| BetreeListCons : T -> Betree_list_t T -> Betree_list_t T -| BetreeListNil : Betree_list_t T +Inductive betree_List_t (T : Type) := +| Betree_List_Cons : T -> betree_List_t T -> betree_List_t T +| Betree_List_Nil : betree_List_t T . -Arguments BetreeListCons {T} _ _. -Arguments BetreeListNil {T}. +Arguments Betree_List_Cons { _ }. +Arguments Betree_List_Nil { _ }. (** [betree_main::betree::UpsertFunState] *) -Inductive Betree_upsert_fun_state_t := -| BetreeUpsertFunStateAdd : u64 -> Betree_upsert_fun_state_t -| BetreeUpsertFunStateSub : u64 -> Betree_upsert_fun_state_t +Inductive betree_UpsertFunState_t := +| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t +| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t . (** [betree_main::betree::Message] *) -Inductive Betree_message_t := -| BetreeMessageInsert : u64 -> Betree_message_t -| BetreeMessageDelete : Betree_message_t -| BetreeMessageUpsert : Betree_upsert_fun_state_t -> Betree_message_t +Inductive betree_Message_t := +| Betree_Message_Insert : u64 -> betree_Message_t +| Betree_Message_Delete : betree_Message_t +| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t . (** [betree_main::betree::Leaf] *) -Record Betree_leaf_t := -mkBetree_leaf_t { - Betree_leaf_id : u64; Betree_leaf_size : u64; +Record betree_Leaf_t := +mkbetree_Leaf_t { + betree_Leaf_id : u64; betree_Leaf_size : u64; } . (** [betree_main::betree::Internal] *) -Inductive Betree_internal_t := -| mkBetree_internal_t : +Inductive betree_Internal_t := +| mkbetree_Internal_t : u64 -> u64 -> - Betree_node_t -> - Betree_node_t -> - Betree_internal_t + betree_Node_t -> + betree_Node_t -> + betree_Internal_t (** [betree_main::betree::Node] *) -with Betree_node_t := -| BetreeNodeInternal : Betree_internal_t -> Betree_node_t -| BetreeNodeLeaf : Betree_leaf_t -> Betree_node_t +with betree_Node_t := +| Betree_Node_Internal : betree_Internal_t -> betree_Node_t +| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t . -Definition Betree_internal_id (x : Betree_internal_t) := - match x with | mkBetree_internal_t x0 _ _ _ => x0 end +Definition betree_Internal_id (x : betree_Internal_t) := + match x with | mkbetree_Internal_t x0 _ _ _ => x0 end . -Notation "x1 .(Betree_internal_id)" := (Betree_internal_id x1) (at level 9). +Notation "x1 .(betree_Internal_id)" := (betree_Internal_id x1) (at level 9). -Definition Betree_internal_pivot (x : Betree_internal_t) := - match x with | mkBetree_internal_t _ x0 _ _ => x0 end +Definition betree_Internal_pivot (x : betree_Internal_t) := + match x with | mkbetree_Internal_t _ x0 _ _ => x0 end . -Notation "x1 .(Betree_internal_pivot)" := (Betree_internal_pivot x1) +Notation "x1 .(betree_Internal_pivot)" := (betree_Internal_pivot x1) (at level 9) . -Definition Betree_internal_left (x : Betree_internal_t) := - match x with | mkBetree_internal_t _ _ x0 _ => x0 end +Definition betree_Internal_left (x : betree_Internal_t) := + match x with | mkbetree_Internal_t _ _ x0 _ => x0 end . -Notation "x1 .(Betree_internal_left)" := (Betree_internal_left x1) (at level 9) +Notation "x1 .(betree_Internal_left)" := (betree_Internal_left x1) (at level 9) . -Definition Betree_internal_right (x : Betree_internal_t) := - match x with | mkBetree_internal_t _ _ _ x0 => x0 end +Definition betree_Internal_right (x : betree_Internal_t) := + match x with | mkbetree_Internal_t _ _ _ x0 => x0 end . -Notation "x1 .(Betree_internal_right)" := (Betree_internal_right x1) +Notation "x1 .(betree_Internal_right)" := (betree_Internal_right x1) (at level 9) . (** [betree_main::betree::Params] *) -Record Betree_params_t := -mkBetree_params_t { - Betree_params_min_flush_size : u64; Betree_params_split_size : u64; +Record betree_Params_t := +mkbetree_Params_t { + betree_Params_min_flush_size : u64; betree_Params_split_size : u64; } . (** [betree_main::betree::NodeIdCounter] *) -Record Betree_node_id_counter_t := -mkBetree_node_id_counter_t { - Betree_node_id_counter_next_node_id : u64; +Record betree_NodeIdCounter_t := +mkbetree_NodeIdCounter_t { + betree_NodeIdCounter_next_node_id : u64; } . (** [betree_main::betree::BeTree] *) -Record Betree_be_tree_t := -mkBetree_be_tree_t { - Betree_be_tree_params : Betree_params_t; - Betree_be_tree_node_id_cnt : Betree_node_id_counter_t; - Betree_be_tree_root : Betree_node_t; +Record betree_BeTree_t := +mkbetree_BeTree_t { + betree_BeTree_params : betree_Params_t; + betree_BeTree_node_id_cnt : betree_NodeIdCounter_t; + betree_BeTree_root : betree_Node_t; } . diff --git a/tests/coq/betree/Primitives.v b/tests/coq/betree/Primitives.v index 71a2d9c3..85e38f01 100644 --- a/tests/coq/betree/Primitives.v +++ b/tests/coq/betree/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -394,12 +396,89 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -419,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -474,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. +Definition alloc_vec_Vec_insert_fwd (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result unit := + if to_Z i <? alloc_vec_Vec_length v then Return tt else Fail_ Failure. -Definition vec_insert_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i <? Z.of_nat (length l) then Return (list_update l (usize_to_nat i) x) else Fail_ Failure). -(* The **backward** function shouldn't be used *) -Definition vec_index_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. - -(* The **backward** function shouldn't be used *) -Definition vec_index_mut_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i <? Z.of_nat (length l) - then Return (list_update l (usize_to_nat i) x) - else Fail_ Failure). +(* [core::slice::index::Range:::get]: forward function *) +Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: forward function *) +Axiom core_slice_index_Range_get_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index e950ba0b..3ca52a9f 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -11,98 +11,101 @@ Import Hashmap_Types. Module Hashmap_Funs. (** [hashmap::hash_key]: forward function *) -Definition hash_key_fwd (k : usize) : result usize := +Definition hash_key (k : usize) : result usize := Return k. (** [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) -Fixpoint hash_map_allocate_slots_loop_fwd - (T : Type) (n : nat) (slots : vec (List_t T)) (n0 : usize) : - result (vec (List_t T)) +Fixpoint hashMap_allocate_slots_loop + (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (n0 : usize) : + result (alloc_vec_Vec (List_t T)) := match n with | O => Fail_ OutOfFuel | S n1 => if n0 s> 0%usize then ( - slots0 <- vec_push_back (List_t T) slots ListNil; + slots0 <- alloc_vec_Vec_push (List_t T) slots List_Nil; n2 <- usize_sub n0 1%usize; - hash_map_allocate_slots_loop_fwd T n1 slots0 n2) + hashMap_allocate_slots_loop T n1 slots0 n2) else Return slots end . (** [hashmap::HashMap::{0}::allocate_slots]: forward function *) -Definition hash_map_allocate_slots_fwd - (T : Type) (n : nat) (slots : vec (List_t T)) (n0 : usize) : - result (vec (List_t T)) +Definition hashMap_allocate_slots + (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (n0 : usize) : + result (alloc_vec_Vec (List_t T)) := - hash_map_allocate_slots_loop_fwd T n slots n0 + hashMap_allocate_slots_loop T n slots n0 . (** [hashmap::HashMap::{0}::new_with_capacity]: forward function *) -Definition hash_map_new_with_capacity_fwd +Definition hashMap_new_with_capacity (T : Type) (n : nat) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : - result (Hash_map_t T) + result (HashMap_t T) := - let v := vec_new (List_t T) in - slots <- hash_map_allocate_slots_fwd T n v capacity; + let v := alloc_vec_Vec_new (List_t T) in + slots <- hashMap_allocate_slots T n v capacity; i <- usize_mul capacity max_load_dividend; i0 <- usize_div i max_load_divisor; Return {| - Hash_map_num_entries := 0%usize; - Hash_map_max_load_factor := (max_load_dividend, max_load_divisor); - Hash_map_max_load := i0; - Hash_map_slots := slots + hashMap_num_entries := 0%usize; + hashMap_max_load_factor := (max_load_dividend, max_load_divisor); + hashMap_max_load := i0; + hashMap_slots := slots |} . (** [hashmap::HashMap::{0}::new]: forward function *) -Definition hash_map_new_fwd (T : Type) (n : nat) : result (Hash_map_t T) := - hash_map_new_with_capacity_fwd T n 32%usize 4%usize 5%usize +Definition hashMap_new (T : Type) (n : nat) : result (HashMap_t T) := + hashMap_new_with_capacity T n 32%usize 4%usize 5%usize . (** [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hash_map_clear_loop_fwd_back - (T : Type) (n : nat) (slots : vec (List_t T)) (i : usize) : - result (vec (List_t T)) +Fixpoint hashMap_clear_loop + (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (i : usize) : + result (alloc_vec_Vec (List_t T)) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len (List_t T) slots in + let i0 := alloc_vec_Vec_len (List_t T) slots in if i s< i0 then ( i1 <- usize_add i 1%usize; - slots0 <- vec_index_mut_back (List_t T) slots i ListNil; - hash_map_clear_loop_fwd_back T n0 slots0 i1) + slots0 <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + slots i List_Nil; + hashMap_clear_loop T n0 slots0 i1) else Return slots end . (** [hashmap::HashMap::{0}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_clear_fwd_back - (T : Type) (n : nat) (self : Hash_map_t T) : result (Hash_map_t T) := - v <- hash_map_clear_loop_fwd_back T n self.(Hash_map_slots) 0%usize; +Definition hashMap_clear + (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := + v <- hashMap_clear_loop T n self.(hashMap_slots) 0%usize; Return {| - Hash_map_num_entries := 0%usize; - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := 0%usize; + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |} . (** [hashmap::HashMap::{0}::len]: forward function *) -Definition hash_map_len_fwd (T : Type) (self : Hash_map_t T) : result usize := - Return self.(Hash_map_num_entries) +Definition hashMap_len (T : Type) (self : HashMap_t T) : result usize := + Return self.(hashMap_num_entries) . (** [hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) -Fixpoint hash_map_insert_in_list_loop_fwd +Fixpoint hashMap_insert_in_list_loop (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result bool := @@ -110,25 +113,25 @@ Fixpoint hash_map_insert_in_list_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key then Return false - else hash_map_insert_in_list_loop_fwd T n0 key value tl - | ListNil => Return true + else hashMap_insert_in_list_loop T n0 key value tl + | List_Nil => Return true end end . (** [hashmap::HashMap::{0}::insert_in_list]: forward function *) -Definition hash_map_insert_in_list_fwd +Definition hashMap_insert_in_list (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result bool := - hash_map_insert_in_list_loop_fwd T n key value ls + hashMap_insert_in_list_loop T n key value ls . (** [hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) -Fixpoint hash_map_insert_in_list_loop_back +Fixpoint hashMap_insert_in_list_loop_back (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result (List_t T) := @@ -136,259 +139,275 @@ Fixpoint hash_map_insert_in_list_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key - then Return (ListCons ckey value tl) + then Return (List_Cons ckey value tl) else ( - tl0 <- hash_map_insert_in_list_loop_back T n0 key value tl; - Return (ListCons ckey cvalue tl0)) - | ListNil => let l := ListNil in Return (ListCons key value l) + tl0 <- hashMap_insert_in_list_loop_back T n0 key value tl; + Return (List_Cons ckey cvalue tl0)) + | List_Nil => let l := List_Nil in Return (List_Cons key value l) end end . (** [hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) -Definition hash_map_insert_in_list_back +Definition hashMap_insert_in_list_back (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result (List_t T) := - hash_map_insert_in_list_loop_back T n key value ls + hashMap_insert_in_list_loop_back T n key value ls . (** [hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_insert_no_resize_fwd_back - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) (value : T) : - result (Hash_map_t T) +Definition hashMap_insert_no_resize + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (value : T) : + result (HashMap_t T) := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - inserted <- hash_map_insert_in_list_fwd T n key value l; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + inserted <- hashMap_insert_in_list T n key value l; if inserted then ( - i0 <- usize_add self.(Hash_map_num_entries) 1%usize; - l0 <- hash_map_insert_in_list_back T n key value l; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + i0 <- usize_add self.(hashMap_num_entries) 1%usize; + l0 <- hashMap_insert_in_list_back T n key value l; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := i0; - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := i0; + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |}) else ( - l0 <- hash_map_insert_in_list_back T n key value l; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + l0 <- hashMap_insert_in_list_back T n key value l; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |}) . -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body : result u32 := Return 4294967295%u32. -Definition core_num_u32_max_c : u32 := core_num_u32_max_body%global. - (** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hash_map_move_elements_from_list_loop_fwd_back - (T : Type) (n : nat) (ntable : Hash_map_t T) (ls : List_t T) : - result (Hash_map_t T) +Fixpoint hashMap_move_elements_from_list_loop + (T : Type) (n : nat) (ntable : HashMap_t T) (ls : List_t T) : + result (HashMap_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons k v tl => - ntable0 <- hash_map_insert_no_resize_fwd_back T n0 ntable k v; - hash_map_move_elements_from_list_loop_fwd_back T n0 ntable0 tl - | ListNil => Return ntable + | List_Cons k v tl => + ntable0 <- hashMap_insert_no_resize T n0 ntable k v; + hashMap_move_elements_from_list_loop T n0 ntable0 tl + | List_Nil => Return ntable end end . (** [hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_move_elements_from_list_fwd_back - (T : Type) (n : nat) (ntable : Hash_map_t T) (ls : List_t T) : - result (Hash_map_t T) +Definition hashMap_move_elements_from_list + (T : Type) (n : nat) (ntable : HashMap_t T) (ls : List_t T) : + result (HashMap_t T) := - hash_map_move_elements_from_list_loop_fwd_back T n ntable ls + hashMap_move_elements_from_list_loop T n ntable ls . (** [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hash_map_move_elements_loop_fwd_back - (T : Type) (n : nat) (ntable : Hash_map_t T) (slots : vec (List_t T)) - (i : usize) : - result ((Hash_map_t T) * (vec (List_t T))) +Fixpoint hashMap_move_elements_loop + (T : Type) (n : nat) (ntable : HashMap_t T) + (slots : alloc_vec_Vec (List_t T)) (i : usize) : + result ((HashMap_t T) * (alloc_vec_Vec (List_t T))) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len (List_t T) slots in + let i0 := alloc_vec_Vec_len (List_t T) slots in if i s< i0 then ( - l <- vec_index_mut_fwd (List_t T) slots i; - let ls := mem_replace_fwd (List_t T) l ListNil in - ntable0 <- hash_map_move_elements_from_list_fwd_back T n0 ntable ls; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + slots i; + let ls := core_mem_replace (List_t T) l List_Nil in + ntable0 <- hashMap_move_elements_from_list T n0 ntable ls; i1 <- usize_add i 1%usize; - let l0 := mem_replace_back (List_t T) l ListNil in - slots0 <- vec_index_mut_back (List_t T) slots i l0; - hash_map_move_elements_loop_fwd_back T n0 ntable0 slots0 i1) + let l0 := core_mem_replace_back (List_t T) l List_Nil in + slots0 <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + slots i l0; + hashMap_move_elements_loop T n0 ntable0 slots0 i1) else Return (ntable, slots) end . (** [hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_move_elements_fwd_back - (T : Type) (n : nat) (ntable : Hash_map_t T) (slots : vec (List_t T)) - (i : usize) : - result ((Hash_map_t T) * (vec (List_t T))) +Definition hashMap_move_elements + (T : Type) (n : nat) (ntable : HashMap_t T) + (slots : alloc_vec_Vec (List_t T)) (i : usize) : + result ((HashMap_t T) * (alloc_vec_Vec (List_t T))) := - hash_map_move_elements_loop_fwd_back T n ntable slots i + hashMap_move_elements_loop T n ntable slots i . (** [hashmap::HashMap::{0}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_try_resize_fwd_back - (T : Type) (n : nat) (self : Hash_map_t T) : result (Hash_map_t T) := - max_usize <- scalar_cast U32 Usize core_num_u32_max_c; - let capacity := vec_len (List_t T) self.(Hash_map_slots) in +Definition hashMap_try_resize + (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := + max_usize <- scalar_cast U32 Usize core_u32_max; + let capacity := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in n1 <- usize_div max_usize 2%usize; - let (i, i0) := self.(Hash_map_max_load_factor) in + let (i, i0) := self.(hashMap_max_load_factor) in i1 <- usize_div n1 i; if capacity s<= i1 then ( i2 <- usize_mul capacity 2%usize; - ntable <- hash_map_new_with_capacity_fwd T n i2 i i0; - p <- - hash_map_move_elements_fwd_back T n ntable self.(Hash_map_slots) 0%usize; + ntable <- hashMap_new_with_capacity T n i2 i i0; + p <- hashMap_move_elements T n ntable self.(hashMap_slots) 0%usize; let (ntable0, _) := p in Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := (i, i0); - Hash_map_max_load := ntable0.(Hash_map_max_load); - Hash_map_slots := ntable0.(Hash_map_slots) + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := (i, i0); + hashMap_max_load := ntable0.(hashMap_max_load); + hashMap_slots := ntable0.(hashMap_slots) |}) else Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := (i, i0); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := self.(Hash_map_slots) + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := (i, i0); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := self.(hashMap_slots) |} . (** [hashmap::HashMap::{0}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_insert_fwd_back - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) (value : T) : - result (Hash_map_t T) +Definition hashMap_insert + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (value : T) : + result (HashMap_t T) := - self0 <- hash_map_insert_no_resize_fwd_back T n self key value; - i <- hash_map_len_fwd T self0; - if i s> self0.(Hash_map_max_load) - then hash_map_try_resize_fwd_back T n self0 + self0 <- hashMap_insert_no_resize T n self key value; + i <- hashMap_len T self0; + if i s> self0.(hashMap_max_load) + then hashMap_try_resize T n self0 else Return self0 . (** [hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) -Fixpoint hash_map_contains_key_in_list_loop_fwd +Fixpoint hashMap_contains_key_in_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result bool := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey t tl => + | List_Cons ckey t tl => if ckey s= key then Return true - else hash_map_contains_key_in_list_loop_fwd T n0 key tl - | ListNil => Return false + else hashMap_contains_key_in_list_loop T n0 key tl + | List_Nil => Return false end end . (** [hashmap::HashMap::{0}::contains_key_in_list]: forward function *) -Definition hash_map_contains_key_in_list_fwd +Definition hashMap_contains_key_in_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result bool := - hash_map_contains_key_in_list_loop_fwd T n key ls + hashMap_contains_key_in_list_loop T n key ls . (** [hashmap::HashMap::{0}::contains_key]: forward function *) -Definition hash_map_contains_key_fwd - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : result bool := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in +Definition hashMap_contains_key + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result bool := + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_fwd (List_t T) self.(Hash_map_slots) hash_mod; - hash_map_contains_key_in_list_fwd T n key l + l <- + alloc_vec_Vec_index (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + hashMap_contains_key_in_list T n key l . (** [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) -Fixpoint hash_map_get_in_list_loop_fwd +Fixpoint hashMap_get_in_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key then Return cvalue - else hash_map_get_in_list_loop_fwd T n0 key tl - | ListNil => Fail_ Failure + else hashMap_get_in_list_loop T n0 key tl + | List_Nil => Fail_ Failure end end . (** [hashmap::HashMap::{0}::get_in_list]: forward function *) -Definition hash_map_get_in_list_fwd +Definition hashMap_get_in_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result T := - hash_map_get_in_list_loop_fwd T n key ls + hashMap_get_in_list_loop T n key ls . (** [hashmap::HashMap::{0}::get]: forward function *) -Definition hash_map_get_fwd - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : result T := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in +Definition hashMap_get + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result T := + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_fwd (List_t T) self.(Hash_map_slots) hash_mod; - hash_map_get_in_list_fwd T n key l + l <- + alloc_vec_Vec_index (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + hashMap_get_in_list T n key l . (** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) -Fixpoint hash_map_get_mut_in_list_loop_fwd +Fixpoint hashMap_get_mut_in_list_loop (T : Type) (n : nat) (ls : List_t T) (key : usize) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key then Return cvalue - else hash_map_get_mut_in_list_loop_fwd T n0 tl key - | ListNil => Fail_ Failure + else hashMap_get_mut_in_list_loop T n0 tl key + | List_Nil => Fail_ Failure end end . (** [hashmap::HashMap::{0}::get_mut_in_list]: forward function *) -Definition hash_map_get_mut_in_list_fwd +Definition hashMap_get_mut_in_list (T : Type) (n : nat) (ls : List_t T) (key : usize) : result T := - hash_map_get_mut_in_list_loop_fwd T n ls key + hashMap_get_mut_in_list_loop T n ls key . (** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) -Fixpoint hash_map_get_mut_in_list_loop_back +Fixpoint hashMap_get_mut_in_list_loop_back (T : Type) (n : nat) (ls : List_t T) (key : usize) (ret : T) : result (List_t T) := @@ -396,196 +415,219 @@ Fixpoint hash_map_get_mut_in_list_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key - then Return (ListCons ckey ret tl) + then Return (List_Cons ckey ret tl) else ( - tl0 <- hash_map_get_mut_in_list_loop_back T n0 tl key ret; - Return (ListCons ckey cvalue tl0)) - | ListNil => Fail_ Failure + tl0 <- hashMap_get_mut_in_list_loop_back T n0 tl key ret; + Return (List_Cons ckey cvalue tl0)) + | List_Nil => Fail_ Failure end end . (** [hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) -Definition hash_map_get_mut_in_list_back +Definition hashMap_get_mut_in_list_back (T : Type) (n : nat) (ls : List_t T) (key : usize) (ret : T) : result (List_t T) := - hash_map_get_mut_in_list_loop_back T n ls key ret + hashMap_get_mut_in_list_loop_back T n ls key ret . (** [hashmap::HashMap::{0}::get_mut]: forward function *) -Definition hash_map_get_mut_fwd - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : result T := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in +Definition hashMap_get_mut + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result T := + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - hash_map_get_mut_in_list_fwd T n l key + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + hashMap_get_mut_in_list T n l key . (** [hashmap::HashMap::{0}::get_mut]: backward function 0 *) -Definition hash_map_get_mut_back - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) (ret : T) : - result (Hash_map_t T) +Definition hashMap_get_mut_back + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (ret : T) : + result (HashMap_t T) := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - l0 <- hash_map_get_mut_in_list_back T n l key ret; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + l0 <- hashMap_get_mut_in_list_back T n l key ret; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |} . (** [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) -Fixpoint hash_map_remove_from_list_loop_fwd +Fixpoint hashMap_remove_from_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (option T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey t tl => + | List_Cons ckey t tl => if ckey s= key then - let mv_ls := mem_replace_fwd (List_t T) (ListCons ckey t tl) ListNil in + let mv_ls := core_mem_replace (List_t T) (List_Cons ckey t tl) List_Nil + in match mv_ls with - | ListCons i cvalue tl0 => Return (Some cvalue) - | ListNil => Fail_ Failure + | List_Cons i cvalue tl0 => Return (Some cvalue) + | List_Nil => Fail_ Failure end - else hash_map_remove_from_list_loop_fwd T n0 key tl - | ListNil => Return None + else hashMap_remove_from_list_loop T n0 key tl + | List_Nil => Return None end end . (** [hashmap::HashMap::{0}::remove_from_list]: forward function *) -Definition hash_map_remove_from_list_fwd +Definition hashMap_remove_from_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (option T) := - hash_map_remove_from_list_loop_fwd T n key ls + hashMap_remove_from_list_loop T n key ls . (** [hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) -Fixpoint hash_map_remove_from_list_loop_back +Fixpoint hashMap_remove_from_list_loop_back (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (List_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey t tl => + | List_Cons ckey t tl => if ckey s= key then - let mv_ls := mem_replace_fwd (List_t T) (ListCons ckey t tl) ListNil in + let mv_ls := core_mem_replace (List_t T) (List_Cons ckey t tl) List_Nil + in match mv_ls with - | ListCons i cvalue tl0 => Return tl0 - | ListNil => Fail_ Failure + | List_Cons i cvalue tl0 => Return tl0 + | List_Nil => Fail_ Failure end else ( - tl0 <- hash_map_remove_from_list_loop_back T n0 key tl; - Return (ListCons ckey t tl0)) - | ListNil => Return ListNil + tl0 <- hashMap_remove_from_list_loop_back T n0 key tl; + Return (List_Cons ckey t tl0)) + | List_Nil => Return List_Nil end end . (** [hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) -Definition hash_map_remove_from_list_back +Definition hashMap_remove_from_list_back (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (List_t T) := - hash_map_remove_from_list_loop_back T n key ls + hashMap_remove_from_list_loop_back T n key ls . (** [hashmap::HashMap::{0}::remove]: forward function *) -Definition hash_map_remove_fwd - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : +Definition hashMap_remove + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result (option T) := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - x <- hash_map_remove_from_list_fwd T n key l; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + x <- hashMap_remove_from_list T n key l; match x with | None => Return None | Some x0 => - _ <- usize_sub self.(Hash_map_num_entries) 1%usize; Return (Some x0) + _ <- usize_sub self.(hashMap_num_entries) 1%usize; Return (Some x0) end . (** [hashmap::HashMap::{0}::remove]: backward function 0 *) -Definition hash_map_remove_back - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : - result (Hash_map_t T) +Definition hashMap_remove_back + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : + result (HashMap_t T) := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - x <- hash_map_remove_from_list_fwd T n key l; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + x <- hashMap_remove_from_list T n key l; match x with | None => - l0 <- hash_map_remove_from_list_back T n key l; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + l0 <- hashMap_remove_from_list_back T n key l; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |} | Some x0 => - i0 <- usize_sub self.(Hash_map_num_entries) 1%usize; - l0 <- hash_map_remove_from_list_back T n key l; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + i0 <- usize_sub self.(hashMap_num_entries) 1%usize; + l0 <- hashMap_remove_from_list_back T n key l; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := i0; - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := i0; + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |} end . (** [hashmap::test1]: forward function *) -Definition test1_fwd (n : nat) : result unit := - hm <- hash_map_new_fwd u64 n; - hm0 <- hash_map_insert_fwd_back u64 n hm 0%usize 42%u64; - hm1 <- hash_map_insert_fwd_back u64 n hm0 128%usize 18%u64; - hm2 <- hash_map_insert_fwd_back u64 n hm1 1024%usize 138%u64; - hm3 <- hash_map_insert_fwd_back u64 n hm2 1056%usize 256%u64; - i <- hash_map_get_fwd u64 n hm3 128%usize; +Definition test1 (n : nat) : result unit := + hm <- hashMap_new u64 n; + hm0 <- hashMap_insert u64 n hm 0%usize 42%u64; + hm1 <- hashMap_insert u64 n hm0 128%usize 18%u64; + hm2 <- hashMap_insert u64 n hm1 1024%usize 138%u64; + hm3 <- hashMap_insert u64 n hm2 1056%usize 256%u64; + i <- hashMap_get u64 n hm3 128%usize; if negb (i s= 18%u64) then Fail_ Failure else ( - hm4 <- hash_map_get_mut_back u64 n hm3 1024%usize 56%u64; - i0 <- hash_map_get_fwd u64 n hm4 1024%usize; + hm4 <- hashMap_get_mut_back u64 n hm3 1024%usize 56%u64; + i0 <- hashMap_get u64 n hm4 1024%usize; if negb (i0 s= 56%u64) then Fail_ Failure else ( - x <- hash_map_remove_fwd u64 n hm4 1024%usize; + x <- hashMap_remove u64 n hm4 1024%usize; match x with | None => Fail_ Failure | Some x0 => if negb (x0 s= 56%u64) then Fail_ Failure else ( - hm5 <- hash_map_remove_back u64 n hm4 1024%usize; - i1 <- hash_map_get_fwd u64 n hm5 0%usize; + hm5 <- hashMap_remove_back u64 n hm4 1024%usize; + i1 <- hashMap_get u64 n hm5 0%usize; if negb (i1 s= 42%u64) then Fail_ Failure else ( - i2 <- hash_map_get_fwd u64 n hm5 128%usize; + i2 <- hashMap_get u64 n hm5 128%usize; if negb (i2 s= 18%u64) then Fail_ Failure else ( - i3 <- hash_map_get_fwd u64 n hm5 1056%usize; + i3 <- hashMap_get u64 n hm5 1056%usize; if negb (i3 s= 256%u64) then Fail_ Failure else Return tt))) end)) . diff --git a/tests/coq/hashmap/Hashmap_Types.v b/tests/coq/hashmap/Hashmap_Types.v index dbde6be9..8529803d 100644 --- a/tests/coq/hashmap/Hashmap_Types.v +++ b/tests/coq/hashmap/Hashmap_Types.v @@ -10,27 +10,27 @@ Module Hashmap_Types. (** [hashmap::List] *) Inductive List_t (T : Type) := -| ListCons : usize -> T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : usize -> T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _ _. -Arguments ListNil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [hashmap::HashMap] *) -Record Hash_map_t (T : Type) := -mkHash_map_t { - Hash_map_num_entries : usize; - Hash_map_max_load_factor : (usize * usize); - Hash_map_max_load : usize; - Hash_map_slots : vec (List_t T); +Record HashMap_t (T : Type) := +mkHashMap_t { + hashMap_num_entries : usize; + hashMap_max_load_factor : (usize * usize); + hashMap_max_load : usize; + hashMap_slots : alloc_vec_Vec (List_t T); } . -Arguments mkHash_map_t {T} _ _ _ _. -Arguments Hash_map_num_entries {T}. -Arguments Hash_map_max_load_factor {T}. -Arguments Hash_map_max_load {T}. -Arguments Hash_map_slots {T}. +Arguments mkHashMap_t { _ }. +Arguments hashMap_num_entries { _ }. +Arguments hashMap_max_load_factor { _ }. +Arguments hashMap_max_load { _ }. +Arguments hashMap_slots { _ }. End Hashmap_Types . diff --git a/tests/coq/hashmap/Primitives.v b/tests/coq/hashmap/Primitives.v index 71a2d9c3..85e38f01 100644 --- a/tests/coq/hashmap/Primitives.v +++ b/tests/coq/hashmap/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -394,12 +396,89 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -419,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -474,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. +Definition alloc_vec_Vec_insert_fwd (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result unit := + if to_Z i <? alloc_vec_Vec_length v then Return tt else Fail_ Failure. -Definition vec_insert_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i <? Z.of_nat (length l) then Return (list_update l (usize_to_nat i) x) else Fail_ Failure). -(* The **backward** function shouldn't be used *) -Definition vec_index_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. - -(* The **backward** function shouldn't be used *) -Definition vec_index_mut_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i <? Z.of_nat (length l) - then Return (list_update l (usize_to_nat i) x) - else Fail_ Failure). +(* [core::slice::index::Range:::get]: forward function *) +Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: forward function *) +Axiom core_slice_index_Range_get_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index 657d5590..eac78186 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -13,656 +13,668 @@ Import HashmapMain_Opaque. Module HashmapMain_Funs. (** [hashmap_main::hashmap::hash_key]: forward function *) -Definition hashmap_hash_key_fwd (k : usize) : result usize := +Definition hashmap_hash_key (k : usize) : result usize := Return k. (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) -Fixpoint hashmap_hash_map_allocate_slots_loop_fwd - (T : Type) (n : nat) (slots : vec (Hashmap_list_t T)) (n0 : usize) : - result (vec (Hashmap_list_t T)) +Fixpoint hashmap_HashMap_allocate_slots_loop + (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (n0 : usize) + : + result (alloc_vec_Vec (hashmap_List_t T)) := match n with | O => Fail_ OutOfFuel | S n1 => if n0 s> 0%usize then ( - slots0 <- vec_push_back (Hashmap_list_t T) slots HashmapListNil; + slots0 <- alloc_vec_Vec_push (hashmap_List_t T) slots Hashmap_List_Nil; n2 <- usize_sub n0 1%usize; - hashmap_hash_map_allocate_slots_loop_fwd T n1 slots0 n2) + hashmap_HashMap_allocate_slots_loop T n1 slots0 n2) else Return slots end . (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function *) -Definition hashmap_hash_map_allocate_slots_fwd - (T : Type) (n : nat) (slots : vec (Hashmap_list_t T)) (n0 : usize) : - result (vec (Hashmap_list_t T)) +Definition hashmap_HashMap_allocate_slots + (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (n0 : usize) + : + result (alloc_vec_Vec (hashmap_List_t T)) := - hashmap_hash_map_allocate_slots_loop_fwd T n slots n0 + hashmap_HashMap_allocate_slots_loop T n slots n0 . (** [hashmap_main::hashmap::HashMap::{0}::new_with_capacity]: forward function *) -Definition hashmap_hash_map_new_with_capacity_fwd +Definition hashmap_HashMap_new_with_capacity (T : Type) (n : nat) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : - result (Hashmap_hash_map_t T) + result (hashmap_HashMap_t T) := - let v := vec_new (Hashmap_list_t T) in - slots <- hashmap_hash_map_allocate_slots_fwd T n v capacity; + let v := alloc_vec_Vec_new (hashmap_List_t T) in + slots <- hashmap_HashMap_allocate_slots T n v capacity; i <- usize_mul capacity max_load_dividend; i0 <- usize_div i max_load_divisor; Return {| - Hashmap_hash_map_num_entries := 0%usize; - Hashmap_hash_map_max_load_factor := (max_load_dividend, max_load_divisor); - Hashmap_hash_map_max_load := i0; - Hashmap_hash_map_slots := slots + hashmap_HashMap_num_entries := 0%usize; + hashmap_HashMap_max_load_factor := (max_load_dividend, max_load_divisor); + hashmap_HashMap_max_load := i0; + hashmap_HashMap_slots := slots |} . (** [hashmap_main::hashmap::HashMap::{0}::new]: forward function *) -Definition hashmap_hash_map_new_fwd - (T : Type) (n : nat) : result (Hashmap_hash_map_t T) := - hashmap_hash_map_new_with_capacity_fwd T n 32%usize 4%usize 5%usize +Definition hashmap_HashMap_new + (T : Type) (n : nat) : result (hashmap_HashMap_t T) := + hashmap_HashMap_new_with_capacity T n 32%usize 4%usize 5%usize . (** [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hashmap_hash_map_clear_loop_fwd_back - (T : Type) (n : nat) (slots : vec (Hashmap_list_t T)) (i : usize) : - result (vec (Hashmap_list_t T)) +Fixpoint hashmap_HashMap_clear_loop + (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : + result (alloc_vec_Vec (hashmap_List_t T)) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len (Hashmap_list_t T) slots in + let i0 := alloc_vec_Vec_len (hashmap_List_t T) slots in if i s< i0 then ( i1 <- usize_add i 1%usize; - slots0 <- vec_index_mut_back (Hashmap_list_t T) slots i HashmapListNil; - hashmap_hash_map_clear_loop_fwd_back T n0 slots0 i1) + slots0 <- + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) slots i Hashmap_List_Nil; + hashmap_HashMap_clear_loop T n0 slots0 i1) else Return slots end . (** [hashmap_main::hashmap::HashMap::{0}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_clear_fwd_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_clear + (T : Type) (n : nat) (self : hashmap_HashMap_t T) : + result (hashmap_HashMap_t T) := - v <- - hashmap_hash_map_clear_loop_fwd_back T n self.(Hashmap_hash_map_slots) - 0%usize; + v <- hashmap_HashMap_clear_loop T n self.(hashmap_HashMap_slots) 0%usize; Return {| - Hashmap_hash_map_num_entries := 0%usize; - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := 0%usize; + hashmap_HashMap_max_load_factor := self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |} . (** [hashmap_main::hashmap::HashMap::{0}::len]: forward function *) -Definition hashmap_hash_map_len_fwd - (T : Type) (self : Hashmap_hash_map_t T) : result usize := - Return self.(Hashmap_hash_map_num_entries) +Definition hashmap_HashMap_len + (T : Type) (self : hashmap_HashMap_t T) : result usize := + Return self.(hashmap_HashMap_num_entries) . (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_insert_in_list_loop_fwd - (T : Type) (n : nat) (key : usize) (value : T) (ls : Hashmap_list_t T) : +Fixpoint hashmap_HashMap_insert_in_list_loop + (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result bool := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key then Return false - else hashmap_hash_map_insert_in_list_loop_fwd T n0 key value tl - | HashmapListNil => Return true + else hashmap_HashMap_insert_in_list_loop T n0 key value tl + | Hashmap_List_Nil => Return true end end . (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: forward function *) -Definition hashmap_hash_map_insert_in_list_fwd - (T : Type) (n : nat) (key : usize) (value : T) (ls : Hashmap_list_t T) : +Definition hashmap_HashMap_insert_in_list + (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result bool := - hashmap_hash_map_insert_in_list_loop_fwd T n key value ls + hashmap_HashMap_insert_in_list_loop T n key value ls . (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) -Fixpoint hashmap_hash_map_insert_in_list_loop_back - (T : Type) (n : nat) (key : usize) (value : T) (ls : Hashmap_list_t T) : - result (Hashmap_list_t T) +Fixpoint hashmap_HashMap_insert_in_list_loop_back + (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : + result (hashmap_List_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key - then Return (HashmapListCons ckey value tl) + then Return (Hashmap_List_Cons ckey value tl) else ( - tl0 <- hashmap_hash_map_insert_in_list_loop_back T n0 key value tl; - Return (HashmapListCons ckey cvalue tl0)) - | HashmapListNil => - let l := HashmapListNil in Return (HashmapListCons key value l) + tl0 <- hashmap_HashMap_insert_in_list_loop_back T n0 key value tl; + Return (Hashmap_List_Cons ckey cvalue tl0)) + | Hashmap_List_Nil => + let l := Hashmap_List_Nil in Return (Hashmap_List_Cons key value l) end end . (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) -Definition hashmap_hash_map_insert_in_list_back - (T : Type) (n : nat) (key : usize) (value : T) (ls : Hashmap_list_t T) : - result (Hashmap_list_t T) +Definition hashmap_HashMap_insert_in_list_back + (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : + result (hashmap_List_t T) := - hashmap_hash_map_insert_in_list_loop_back T n key value ls + hashmap_HashMap_insert_in_list_loop_back T n key value ls . (** [hashmap_main::hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_insert_no_resize_fwd_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) (value : T) - : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_insert_no_resize + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (value : T) : + result (hashmap_HashMap_t T) := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - inserted <- hashmap_hash_map_insert_in_list_fwd T n key value l; + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + inserted <- hashmap_HashMap_insert_in_list T n key value l; if inserted then ( - i0 <- usize_add self.(Hashmap_hash_map_num_entries) 1%usize; - l0 <- hashmap_hash_map_insert_in_list_back T n key value l; + i0 <- usize_add self.(hashmap_HashMap_num_entries) 1%usize; + l0 <- hashmap_HashMap_insert_in_list_back T n key value l; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := i0; - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := i0; + hashmap_HashMap_max_load_factor := + self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |}) else ( - l0 <- hashmap_hash_map_insert_in_list_back T n key value l; + l0 <- hashmap_HashMap_insert_in_list_back T n key value l; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := + self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |}) . -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body : result u32 := Return 4294967295%u32. -Definition core_num_u32_max_c : u32 := core_num_u32_max_body%global. - (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hashmap_hash_map_move_elements_from_list_loop_fwd_back - (T : Type) (n : nat) (ntable : Hashmap_hash_map_t T) (ls : Hashmap_list_t T) - : - result (Hashmap_hash_map_t T) +Fixpoint hashmap_HashMap_move_elements_from_list_loop + (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (ls : hashmap_List_t T) : + result (hashmap_HashMap_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons k v tl => - ntable0 <- hashmap_hash_map_insert_no_resize_fwd_back T n0 ntable k v; - hashmap_hash_map_move_elements_from_list_loop_fwd_back T n0 ntable0 tl - | HashmapListNil => Return ntable + | Hashmap_List_Cons k v tl => + ntable0 <- hashmap_HashMap_insert_no_resize T n0 ntable k v; + hashmap_HashMap_move_elements_from_list_loop T n0 ntable0 tl + | Hashmap_List_Nil => Return ntable end end . (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_move_elements_from_list_fwd_back - (T : Type) (n : nat) (ntable : Hashmap_hash_map_t T) (ls : Hashmap_list_t T) - : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_move_elements_from_list + (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (ls : hashmap_List_t T) : + result (hashmap_HashMap_t T) := - hashmap_hash_map_move_elements_from_list_loop_fwd_back T n ntable ls + hashmap_HashMap_move_elements_from_list_loop T n ntable ls . (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hashmap_hash_map_move_elements_loop_fwd_back - (T : Type) (n : nat) (ntable : Hashmap_hash_map_t T) - (slots : vec (Hashmap_list_t T)) (i : usize) : - result ((Hashmap_hash_map_t T) * (vec (Hashmap_list_t T))) +Fixpoint hashmap_HashMap_move_elements_loop + (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) + (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : + result ((hashmap_HashMap_t T) * (alloc_vec_Vec (hashmap_List_t T))) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len (Hashmap_list_t T) slots in + let i0 := alloc_vec_Vec_len (hashmap_List_t T) slots in if i s< i0 then ( - l <- vec_index_mut_fwd (Hashmap_list_t T) slots i; - let ls := mem_replace_fwd (Hashmap_list_t T) l HashmapListNil in - ntable0 <- - hashmap_hash_map_move_elements_from_list_fwd_back T n0 ntable ls; + l <- + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) slots i; + let ls := core_mem_replace (hashmap_List_t T) l Hashmap_List_Nil in + ntable0 <- hashmap_HashMap_move_elements_from_list T n0 ntable ls; i1 <- usize_add i 1%usize; - let l0 := mem_replace_back (Hashmap_list_t T) l HashmapListNil in - slots0 <- vec_index_mut_back (Hashmap_list_t T) slots i l0; - hashmap_hash_map_move_elements_loop_fwd_back T n0 ntable0 slots0 i1) + let l0 := core_mem_replace_back (hashmap_List_t T) l Hashmap_List_Nil in + slots0 <- + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) slots i l0; + hashmap_HashMap_move_elements_loop T n0 ntable0 slots0 i1) else Return (ntable, slots) end . (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_move_elements_fwd_back - (T : Type) (n : nat) (ntable : Hashmap_hash_map_t T) - (slots : vec (Hashmap_list_t T)) (i : usize) : - result ((Hashmap_hash_map_t T) * (vec (Hashmap_list_t T))) +Definition hashmap_HashMap_move_elements + (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) + (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : + result ((hashmap_HashMap_t T) * (alloc_vec_Vec (hashmap_List_t T))) := - hashmap_hash_map_move_elements_loop_fwd_back T n ntable slots i + hashmap_HashMap_move_elements_loop T n ntable slots i . (** [hashmap_main::hashmap::HashMap::{0}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_try_resize_fwd_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_try_resize + (T : Type) (n : nat) (self : hashmap_HashMap_t T) : + result (hashmap_HashMap_t T) := - max_usize <- scalar_cast U32 Usize core_num_u32_max_c; - let capacity := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + max_usize <- scalar_cast U32 Usize core_u32_max; + let capacity := + alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in n1 <- usize_div max_usize 2%usize; - let (i, i0) := self.(Hashmap_hash_map_max_load_factor) in + let (i, i0) := self.(hashmap_HashMap_max_load_factor) in i1 <- usize_div n1 i; if capacity s<= i1 then ( i2 <- usize_mul capacity 2%usize; - ntable <- hashmap_hash_map_new_with_capacity_fwd T n i2 i i0; + ntable <- hashmap_HashMap_new_with_capacity T n i2 i i0; p <- - hashmap_hash_map_move_elements_fwd_back T n ntable - self.(Hashmap_hash_map_slots) 0%usize; + hashmap_HashMap_move_elements T n ntable self.(hashmap_HashMap_slots) + 0%usize; let (ntable0, _) := p in Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := (i, i0); - Hashmap_hash_map_max_load := ntable0.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := ntable0.(Hashmap_hash_map_slots) + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := (i, i0); + hashmap_HashMap_max_load := ntable0.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := ntable0.(hashmap_HashMap_slots) |}) else Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := (i, i0); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := self.(Hashmap_hash_map_slots) + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := (i, i0); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := self.(hashmap_HashMap_slots) |} . (** [hashmap_main::hashmap::HashMap::{0}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_insert_fwd_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) (value : T) - : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_insert + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (value : T) : + result (hashmap_HashMap_t T) := - self0 <- hashmap_hash_map_insert_no_resize_fwd_back T n self key value; - i <- hashmap_hash_map_len_fwd T self0; - if i s> self0.(Hashmap_hash_map_max_load) - then hashmap_hash_map_try_resize_fwd_back T n self0 + self0 <- hashmap_HashMap_insert_no_resize T n self key value; + i <- hashmap_HashMap_len T self0; + if i s> self0.(hashmap_HashMap_max_load) + then hashmap_HashMap_try_resize T n self0 else Return self0 . (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_contains_key_in_list_loop_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : result bool := +Fixpoint hashmap_HashMap_contains_key_in_list_loop + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result bool := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey t tl => + | Hashmap_List_Cons ckey t tl => if ckey s= key then Return true - else hashmap_hash_map_contains_key_in_list_loop_fwd T n0 key tl - | HashmapListNil => Return false + else hashmap_HashMap_contains_key_in_list_loop T n0 key tl + | Hashmap_List_Nil => Return false end end . (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: forward function *) -Definition hashmap_hash_map_contains_key_in_list_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : result bool := - hashmap_hash_map_contains_key_in_list_loop_fwd T n key ls +Definition hashmap_HashMap_contains_key_in_list + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result bool := + hashmap_HashMap_contains_key_in_list_loop T n key ls . (** [hashmap_main::hashmap::HashMap::{0}::contains_key]: forward function *) -Definition hashmap_hash_map_contains_key_fwd - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : +Definition hashmap_HashMap_contains_key + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result bool := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - hashmap_hash_map_contains_key_in_list_fwd T n key l + l <- + alloc_vec_Vec_index (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + hashmap_HashMap_contains_key_in_list T n key l . (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_get_in_list_loop_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : result T := +Fixpoint hashmap_HashMap_get_in_list_loop + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key then Return cvalue - else hashmap_hash_map_get_in_list_loop_fwd T n0 key tl - | HashmapListNil => Fail_ Failure + else hashmap_HashMap_get_in_list_loop T n0 key tl + | Hashmap_List_Nil => Fail_ Failure end end . (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: forward function *) -Definition hashmap_hash_map_get_in_list_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : result T := - hashmap_hash_map_get_in_list_loop_fwd T n key ls +Definition hashmap_HashMap_get_in_list + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result T := + hashmap_HashMap_get_in_list_loop T n key ls . (** [hashmap_main::hashmap::HashMap::{0}::get]: forward function *) -Definition hashmap_hash_map_get_fwd - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : - result T - := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in +Definition hashmap_HashMap_get + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result T := + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - hashmap_hash_map_get_in_list_fwd T n key l + l <- + alloc_vec_Vec_index (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + hashmap_HashMap_get_in_list T n key l . (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_get_mut_in_list_loop_fwd - (T : Type) (n : nat) (ls : Hashmap_list_t T) (key : usize) : result T := +Fixpoint hashmap_HashMap_get_mut_in_list_loop + (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key then Return cvalue - else hashmap_hash_map_get_mut_in_list_loop_fwd T n0 tl key - | HashmapListNil => Fail_ Failure + else hashmap_HashMap_get_mut_in_list_loop T n0 tl key + | Hashmap_List_Nil => Fail_ Failure end end . (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: forward function *) -Definition hashmap_hash_map_get_mut_in_list_fwd - (T : Type) (n : nat) (ls : Hashmap_list_t T) (key : usize) : result T := - hashmap_hash_map_get_mut_in_list_loop_fwd T n ls key +Definition hashmap_HashMap_get_mut_in_list + (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) : result T := + hashmap_HashMap_get_mut_in_list_loop T n ls key . (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) -Fixpoint hashmap_hash_map_get_mut_in_list_loop_back - (T : Type) (n : nat) (ls : Hashmap_list_t T) (key : usize) (ret : T) : - result (Hashmap_list_t T) +Fixpoint hashmap_HashMap_get_mut_in_list_loop_back + (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) (ret : T) : + result (hashmap_List_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key - then Return (HashmapListCons ckey ret tl) + then Return (Hashmap_List_Cons ckey ret tl) else ( - tl0 <- hashmap_hash_map_get_mut_in_list_loop_back T n0 tl key ret; - Return (HashmapListCons ckey cvalue tl0)) - | HashmapListNil => Fail_ Failure + tl0 <- hashmap_HashMap_get_mut_in_list_loop_back T n0 tl key ret; + Return (Hashmap_List_Cons ckey cvalue tl0)) + | Hashmap_List_Nil => Fail_ Failure end end . (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) -Definition hashmap_hash_map_get_mut_in_list_back - (T : Type) (n : nat) (ls : Hashmap_list_t T) (key : usize) (ret : T) : - result (Hashmap_list_t T) +Definition hashmap_HashMap_get_mut_in_list_back + (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) (ret : T) : + result (hashmap_List_t T) := - hashmap_hash_map_get_mut_in_list_loop_back T n ls key ret + hashmap_HashMap_get_mut_in_list_loop_back T n ls key ret . (** [hashmap_main::hashmap::HashMap::{0}::get_mut]: forward function *) -Definition hashmap_hash_map_get_mut_fwd - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : - result T - := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in +Definition hashmap_HashMap_get_mut + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result T := + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - hashmap_hash_map_get_mut_in_list_fwd T n l key + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + hashmap_HashMap_get_mut_in_list T n l key . (** [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 *) -Definition hashmap_hash_map_get_mut_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) (ret : T) : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_get_mut_back + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (ret : T) : + result (hashmap_HashMap_t T) := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - l0 <- hashmap_hash_map_get_mut_in_list_back T n l key ret; + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + l0 <- hashmap_HashMap_get_mut_in_list_back T n l key ret; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |} . (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_remove_from_list_loop_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : +Fixpoint hashmap_HashMap_remove_from_list_loop + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (option T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey t tl => + | Hashmap_List_Cons ckey t tl => if ckey s= key then let mv_ls := - mem_replace_fwd (Hashmap_list_t T) (HashmapListCons ckey t tl) - HashmapListNil in + core_mem_replace (hashmap_List_t T) (Hashmap_List_Cons ckey t tl) + Hashmap_List_Nil in match mv_ls with - | HashmapListCons i cvalue tl0 => Return (Some cvalue) - | HashmapListNil => Fail_ Failure + | Hashmap_List_Cons i cvalue tl0 => Return (Some cvalue) + | Hashmap_List_Nil => Fail_ Failure end - else hashmap_hash_map_remove_from_list_loop_fwd T n0 key tl - | HashmapListNil => Return None + else hashmap_HashMap_remove_from_list_loop T n0 key tl + | Hashmap_List_Nil => Return None end end . (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function *) -Definition hashmap_hash_map_remove_from_list_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : +Definition hashmap_HashMap_remove_from_list + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (option T) := - hashmap_hash_map_remove_from_list_loop_fwd T n key ls + hashmap_HashMap_remove_from_list_loop T n key ls . (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) -Fixpoint hashmap_hash_map_remove_from_list_loop_back - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : - result (Hashmap_list_t T) +Fixpoint hashmap_HashMap_remove_from_list_loop_back + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : + result (hashmap_List_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey t tl => + | Hashmap_List_Cons ckey t tl => if ckey s= key then let mv_ls := - mem_replace_fwd (Hashmap_list_t T) (HashmapListCons ckey t tl) - HashmapListNil in + core_mem_replace (hashmap_List_t T) (Hashmap_List_Cons ckey t tl) + Hashmap_List_Nil in match mv_ls with - | HashmapListCons i cvalue tl0 => Return tl0 - | HashmapListNil => Fail_ Failure + | Hashmap_List_Cons i cvalue tl0 => Return tl0 + | Hashmap_List_Nil => Fail_ Failure end else ( - tl0 <- hashmap_hash_map_remove_from_list_loop_back T n0 key tl; - Return (HashmapListCons ckey t tl0)) - | HashmapListNil => Return HashmapListNil + tl0 <- hashmap_HashMap_remove_from_list_loop_back T n0 key tl; + Return (Hashmap_List_Cons ckey t tl0)) + | Hashmap_List_Nil => Return Hashmap_List_Nil end end . (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) -Definition hashmap_hash_map_remove_from_list_back - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : - result (Hashmap_list_t T) +Definition hashmap_HashMap_remove_from_list_back + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : + result (hashmap_List_t T) := - hashmap_hash_map_remove_from_list_loop_back T n key ls + hashmap_HashMap_remove_from_list_loop_back T n key ls . (** [hashmap_main::hashmap::HashMap::{0}::remove]: forward function *) -Definition hashmap_hash_map_remove_fwd - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : +Definition hashmap_HashMap_remove + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result (option T) := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - x <- hashmap_hash_map_remove_from_list_fwd T n key l; + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + x <- hashmap_HashMap_remove_from_list T n key l; match x with | None => Return None | Some x0 => - _ <- usize_sub self.(Hashmap_hash_map_num_entries) 1%usize; - Return (Some x0) + _ <- usize_sub self.(hashmap_HashMap_num_entries) 1%usize; Return (Some x0) end . (** [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 *) -Definition hashmap_hash_map_remove_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_remove_back + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : + result (hashmap_HashMap_t T) := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - x <- hashmap_hash_map_remove_from_list_fwd T n key l; + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + x <- hashmap_HashMap_remove_from_list T n key l; match x with | None => - l0 <- hashmap_hash_map_remove_from_list_back T n key l; + l0 <- hashmap_HashMap_remove_from_list_back T n key l; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := + self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |} | Some x0 => - i0 <- usize_sub self.(Hashmap_hash_map_num_entries) 1%usize; - l0 <- hashmap_hash_map_remove_from_list_back T n key l; + i0 <- usize_sub self.(hashmap_HashMap_num_entries) 1%usize; + l0 <- hashmap_HashMap_remove_from_list_back T n key l; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := i0; - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := i0; + hashmap_HashMap_max_load_factor := + self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |} end . (** [hashmap_main::hashmap::test1]: forward function *) -Definition hashmap_test1_fwd (n : nat) : result unit := - hm <- hashmap_hash_map_new_fwd u64 n; - hm0 <- hashmap_hash_map_insert_fwd_back u64 n hm 0%usize 42%u64; - hm1 <- hashmap_hash_map_insert_fwd_back u64 n hm0 128%usize 18%u64; - hm2 <- hashmap_hash_map_insert_fwd_back u64 n hm1 1024%usize 138%u64; - hm3 <- hashmap_hash_map_insert_fwd_back u64 n hm2 1056%usize 256%u64; - i <- hashmap_hash_map_get_fwd u64 n hm3 128%usize; +Definition hashmap_test1 (n : nat) : result unit := + hm <- hashmap_HashMap_new u64 n; + hm0 <- hashmap_HashMap_insert u64 n hm 0%usize 42%u64; + hm1 <- hashmap_HashMap_insert u64 n hm0 128%usize 18%u64; + hm2 <- hashmap_HashMap_insert u64 n hm1 1024%usize 138%u64; + hm3 <- hashmap_HashMap_insert u64 n hm2 1056%usize 256%u64; + i <- hashmap_HashMap_get u64 n hm3 128%usize; if negb (i s= 18%u64) then Fail_ Failure else ( - hm4 <- hashmap_hash_map_get_mut_back u64 n hm3 1024%usize 56%u64; - i0 <- hashmap_hash_map_get_fwd u64 n hm4 1024%usize; + hm4 <- hashmap_HashMap_get_mut_back u64 n hm3 1024%usize 56%u64; + i0 <- hashmap_HashMap_get u64 n hm4 1024%usize; if negb (i0 s= 56%u64) then Fail_ Failure else ( - x <- hashmap_hash_map_remove_fwd u64 n hm4 1024%usize; + x <- hashmap_HashMap_remove u64 n hm4 1024%usize; match x with | None => Fail_ Failure | Some x0 => if negb (x0 s= 56%u64) then Fail_ Failure else ( - hm5 <- hashmap_hash_map_remove_back u64 n hm4 1024%usize; - i1 <- hashmap_hash_map_get_fwd u64 n hm5 0%usize; + hm5 <- hashmap_HashMap_remove_back u64 n hm4 1024%usize; + i1 <- hashmap_HashMap_get u64 n hm5 0%usize; if negb (i1 s= 42%u64) then Fail_ Failure else ( - i2 <- hashmap_hash_map_get_fwd u64 n hm5 128%usize; + i2 <- hashmap_HashMap_get u64 n hm5 128%usize; if negb (i2 s= 18%u64) then Fail_ Failure else ( - i3 <- hashmap_hash_map_get_fwd u64 n hm5 1056%usize; + i3 <- hashmap_HashMap_get u64 n hm5 1056%usize; if negb (i3 s= 256%u64) then Fail_ Failure else Return tt))) end)) . (** [hashmap_main::insert_on_disk]: forward function *) -Definition insert_on_disk_fwd +Definition insert_on_disk (n : nat) (key : usize) (value : u64) (st : state) : result (state * unit) := - p <- hashmap_utils_deserialize_fwd st; + p <- hashmap_utils_deserialize st; let (st0, hm) := p in - hm0 <- hashmap_hash_map_insert_fwd_back u64 n hm key value; - p0 <- hashmap_utils_serialize_fwd hm0 st0; + hm0 <- hashmap_HashMap_insert u64 n hm key value; + p0 <- hashmap_utils_serialize hm0 st0; let (st1, _) := p0 in Return (st1, tt) . (** [hashmap_main::main]: forward function *) -Definition main_fwd : result unit := +Definition main : result unit := Return tt. -(** Unit test for [hashmap_main::main] *) -Check (main_fwd )%return. - End HashmapMain_Funs . diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v b/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v index 2d17cc29..5e376239 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v @@ -11,13 +11,13 @@ Import HashmapMain_Types. Module HashmapMain_Opaque. (** [hashmap_main::hashmap_utils::deserialize]: forward function *) -Axiom hashmap_utils_deserialize_fwd - : state -> result (state * (Hashmap_hash_map_t u64)) +Axiom hashmap_utils_deserialize + : state -> result (state * (hashmap_HashMap_t u64)) . (** [hashmap_main::hashmap_utils::serialize]: forward function *) -Axiom hashmap_utils_serialize_fwd - : Hashmap_hash_map_t u64 -> state -> result (state * unit) +Axiom hashmap_utils_serialize + : hashmap_HashMap_t u64 -> state -> result (state * unit) . End HashmapMain_Opaque . diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Types.v b/tests/coq/hashmap_on_disk/HashmapMain_Types.v index 36aaaf25..95e5f35b 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Types.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Types.v @@ -9,29 +9,29 @@ Local Open Scope Primitives_scope. Module HashmapMain_Types. (** [hashmap_main::hashmap::List] *) -Inductive Hashmap_list_t (T : Type) := -| HashmapListCons : usize -> T -> Hashmap_list_t T -> Hashmap_list_t T -| HashmapListNil : Hashmap_list_t T +Inductive hashmap_List_t (T : Type) := +| Hashmap_List_Cons : usize -> T -> hashmap_List_t T -> hashmap_List_t T +| Hashmap_List_Nil : hashmap_List_t T . -Arguments HashmapListCons {T} _ _ _. -Arguments HashmapListNil {T}. +Arguments Hashmap_List_Cons { _ }. +Arguments Hashmap_List_Nil { _ }. (** [hashmap_main::hashmap::HashMap] *) -Record Hashmap_hash_map_t (T : Type) := -mkHashmap_hash_map_t { - Hashmap_hash_map_num_entries : usize; - Hashmap_hash_map_max_load_factor : (usize * usize); - Hashmap_hash_map_max_load : usize; - Hashmap_hash_map_slots : vec (Hashmap_list_t T); +Record hashmap_HashMap_t (T : Type) := +mkhashmap_HashMap_t { + hashmap_HashMap_num_entries : usize; + hashmap_HashMap_max_load_factor : (usize * usize); + hashmap_HashMap_max_load : usize; + hashmap_HashMap_slots : alloc_vec_Vec (hashmap_List_t T); } . -Arguments mkHashmap_hash_map_t {T} _ _ _ _. -Arguments Hashmap_hash_map_num_entries {T}. -Arguments Hashmap_hash_map_max_load_factor {T}. -Arguments Hashmap_hash_map_max_load {T}. -Arguments Hashmap_hash_map_slots {T}. +Arguments mkhashmap_HashMap_t { _ }. +Arguments hashmap_HashMap_num_entries { _ }. +Arguments hashmap_HashMap_max_load_factor { _ }. +Arguments hashmap_HashMap_max_load { _ }. +Arguments hashmap_HashMap_slots { _ }. (** The state type used in the state-error monad *) Axiom state : Type. diff --git a/tests/coq/hashmap_on_disk/Primitives.v b/tests/coq/hashmap_on_disk/Primitives.v index 71a2d9c3..85e38f01 100644 --- a/tests/coq/hashmap_on_disk/Primitives.v +++ b/tests/coq/hashmap_on_disk/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -394,12 +396,89 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -419,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -474,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. +Definition alloc_vec_Vec_insert_fwd (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result unit := + if to_Z i <? alloc_vec_Vec_length v then Return tt else Fail_ Failure. -Definition vec_insert_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i <? Z.of_nat (length l) then Return (list_update l (usize_to_nat i) x) else Fail_ Failure). -(* The **backward** function shouldn't be used *) -Definition vec_index_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. - -(* The **backward** function shouldn't be used *) -Definition vec_index_mut_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i <? Z.of_nat (length l) - then Return (list_update l (usize_to_nat i) x) - else Fail_ Failure). +(* [core::slice::index::Range:::get]: forward function *) +Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: forward function *) +Axiom core_slice_index_Range_get_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/misc/Constants.v b/tests/coq/misc/Constants.v index f1c32730..03653f69 100644 --- a/tests/coq/misc/Constants.v +++ b/tests/coq/misc/Constants.v @@ -12,12 +12,8 @@ Module Constants. Definition x0_body : result u32 := Return 0%u32. Definition x0_c : u32 := x0_body%global. -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body : result u32 := Return 4294967295%u32. -Definition core_num_u32_max_c : u32 := core_num_u32_max_body%global. - (** [constants::X1] *) -Definition x1_body : result u32 := Return core_num_u32_max_c. +Definition x1_body : result u32 := Return core_u32_max. Definition x1_c : u32 := x1_body%global. (** [constants::X2] *) @@ -25,36 +21,35 @@ Definition x2_body : result u32 := Return 3%u32. Definition x2_c : u32 := x2_body%global. (** [constants::incr]: forward function *) -Definition incr_fwd (n : u32) : result u32 := +Definition incr (n : u32) : result u32 := u32_add n 1%u32. (** [constants::X3] *) -Definition x3_body : result u32 := incr_fwd 32%u32. +Definition x3_body : result u32 := incr 32%u32. Definition x3_c : u32 := x3_body%global. (** [constants::mk_pair0]: forward function *) -Definition mk_pair0_fwd (x : u32) (y : u32) : result (u32 * u32) := - Return (x, y) -. +Definition mk_pair0 (x : u32) (y : u32) : result (u32 * u32) := + Return (x, y). (** [constants::Pair] *) -Record Pair_t (T1 T2 : Type) := mkPair_t { Pair_x : T1; Pair_y : T2; }. +Record Pair_t (T1 T2 : Type) := mkPair_t { pair_x : T1; pair_y : T2; }. -Arguments mkPair_t {T1} {T2} _ _. -Arguments Pair_x {T1} {T2}. -Arguments Pair_y {T1} {T2}. +Arguments mkPair_t { _ _ }. +Arguments pair_x { _ _ }. +Arguments pair_y { _ _ }. (** [constants::mk_pair1]: forward function *) -Definition mk_pair1_fwd (x : u32) (y : u32) : result (Pair_t u32 u32) := - Return {| Pair_x := x; Pair_y := y |} +Definition mk_pair1 (x : u32) (y : u32) : result (Pair_t u32 u32) := + Return {| pair_x := x; pair_y := y |} . (** [constants::P0] *) -Definition p0_body : result (u32 * u32) := mk_pair0_fwd 0%u32 1%u32. +Definition p0_body : result (u32 * u32) := mk_pair0 0%u32 1%u32. Definition p0_c : (u32 * u32) := p0_body%global. (** [constants::P1] *) -Definition p1_body : result (Pair_t u32 u32) := mk_pair1_fwd 0%u32 1%u32. +Definition p1_body : result (Pair_t u32 u32) := mk_pair1 0%u32 1%u32. Definition p1_c : Pair_t u32 u32 := p1_body%global. (** [constants::P2] *) @@ -63,31 +58,31 @@ Definition p2_c : (u32 * u32) := p2_body%global. (** [constants::P3] *) Definition p3_body : result (Pair_t u32 u32) := - Return {| Pair_x := 0%u32; Pair_y := 1%u32 |} + Return {| pair_x := 0%u32; pair_y := 1%u32 |} . Definition p3_c : Pair_t u32 u32 := p3_body%global. (** [constants::Wrap] *) -Record Wrap_t (T : Type) := mkWrap_t { Wrap_val : T; }. +Record Wrap_t (T : Type) := mkWrap_t { wrap_value : T; }. -Arguments mkWrap_t {T} _. -Arguments Wrap_val {T}. +Arguments mkWrap_t { _ }. +Arguments wrap_value { _ }. (** [constants::Wrap::{0}::new]: forward function *) -Definition wrap_new_fwd (T : Type) (val : T) : result (Wrap_t T) := - Return {| Wrap_val := val |} +Definition wrap_new (T : Type) (value : T) : result (Wrap_t T) := + Return {| wrap_value := value |} . (** [constants::Y] *) -Definition y_body : result (Wrap_t i32) := wrap_new_fwd i32 2%i32. +Definition y_body : result (Wrap_t i32) := wrap_new i32 2%i32. Definition y_c : Wrap_t i32 := y_body%global. (** [constants::unwrap_y]: forward function *) -Definition unwrap_y_fwd : result i32 := - Return y_c.(Wrap_val). +Definition unwrap_y : result i32 := + Return y_c.(wrap_value). (** [constants::YVAL] *) -Definition yval_body : result i32 := unwrap_y_fwd. +Definition yval_body : result i32 := unwrap_y. Definition yval_c : i32 := yval_body%global. (** [constants::get_z1::Z1] *) @@ -95,11 +90,11 @@ Definition get_z1_z1_body : result i32 := Return 3%i32. Definition get_z1_z1_c : i32 := get_z1_z1_body%global. (** [constants::get_z1]: forward function *) -Definition get_z1_fwd : result i32 := +Definition get_z1 : result i32 := Return get_z1_z1_c. (** [constants::add]: forward function *) -Definition add_fwd (a : i32) (b : i32) : result i32 := +Definition add (a : i32) (b : i32) : result i32 := i32_add a b. (** [constants::Q1] *) @@ -111,20 +106,19 @@ Definition q2_body : result i32 := Return q1_c. Definition q2_c : i32 := q2_body%global. (** [constants::Q3] *) -Definition q3_body : result i32 := add_fwd q2_c 3%i32. +Definition q3_body : result i32 := add q2_c 3%i32. Definition q3_c : i32 := q3_body%global. (** [constants::get_z2]: forward function *) -Definition get_z2_fwd : result i32 := - i <- get_z1_fwd; i0 <- add_fwd i q3_c; add_fwd q1_c i0 -. +Definition get_z2 : result i32 := + i <- get_z1; i0 <- add i q3_c; add q1_c i0. (** [constants::S1] *) Definition s1_body : result u32 := Return 6%u32. Definition s1_c : u32 := s1_body%global. (** [constants::S2] *) -Definition s2_body : result u32 := incr_fwd s1_c. +Definition s2_body : result u32 := incr s1_c. Definition s2_c : u32 := s2_body%global. (** [constants::S3] *) @@ -132,7 +126,7 @@ Definition s3_body : result (Pair_t u32 u32) := Return p3_c. Definition s3_c : Pair_t u32 u32 := s3_body%global. (** [constants::S4] *) -Definition s4_body : result (Pair_t u32 u32) := mk_pair1_fwd 7%u32 8%u32. +Definition s4_body : result (Pair_t u32 u32) := mk_pair1 7%u32 8%u32. Definition s4_c : Pair_t u32 u32 := s4_body%global. End Constants . diff --git a/tests/coq/misc/External_Funs.v b/tests/coq/misc/External_Funs.v index 28370b2b..018ce13c 100644 --- a/tests/coq/misc/External_Funs.v +++ b/tests/coq/misc/External_Funs.v @@ -13,9 +13,9 @@ Import External_Opaque. Module External_Funs. (** [external::swap]: forward function *) -Definition swap_fwd +Definition swap (T : Type) (x : T) (y : T) (st : state) : result (state * unit) := - p <- core_mem_swap_fwd T x y st; + p <- core_mem_swap T x y st; let (st0, _) := p in p0 <- core_mem_swap_back0 T x y st st0; let (st1, _) := p0 in @@ -29,7 +29,7 @@ Definition swap_back (T : Type) (x : T) (y : T) (st : state) (st0 : state) : result (state * (T * T)) := - p <- core_mem_swap_fwd T x y st; + p <- core_mem_swap T x y st; let (st1, _) := p in p0 <- core_mem_swap_back0 T x y st st1; let (st2, x0) := p0 in @@ -39,25 +39,27 @@ Definition swap_back . (** [external::test_new_non_zero_u32]: forward function *) -Definition test_new_non_zero_u32_fwd - (x : u32) (st : state) : result (state * Core_num_nonzero_non_zero_u32_t) := - p <- core_num_nonzero_non_zero_u32_new_fwd x st; - let (st0, opt) := p in - core_option_option_unwrap_fwd Core_num_nonzero_non_zero_u32_t opt st0 +Definition test_new_non_zero_u32 + (x : u32) (st : state) : result (state * core_num_nonzero_NonZeroU32_t) := + p <- core_num_nonzero_NonZeroU32_new x st; + let (st0, o) := p in + core_option_Option_unwrap core_num_nonzero_NonZeroU32_t o st0 . (** [external::test_vec]: forward function *) -Definition test_vec_fwd : result unit := - let v := vec_new u32 in _ <- vec_push_back u32 v 0%u32; Return tt +Definition test_vec : result unit := + let v := alloc_vec_Vec_new u32 in + _ <- alloc_vec_Vec_push u32 v 0%u32; + Return tt . (** Unit test for [external::test_vec] *) -Check (test_vec_fwd )%return. +Check (test_vec )%return. (** [external::custom_swap]: forward function *) -Definition custom_swap_fwd +Definition custom_swap (T : Type) (x : T) (y : T) (st : state) : result (state * T) := - p <- core_mem_swap_fwd T x y st; + p <- core_mem_swap T x y st; let (st0, _) := p in p0 <- core_mem_swap_back0 T x y st st0; let (st1, x0) := p0 in @@ -71,7 +73,7 @@ Definition custom_swap_back (T : Type) (x : T) (y : T) (st : state) (ret : T) (st0 : state) : result (state * (T * T)) := - p <- core_mem_swap_fwd T x y st; + p <- core_mem_swap T x y st; let (st1, _) := p in p0 <- core_mem_swap_back0 T x y st st1; let (st2, _) := p0 in @@ -81,9 +83,9 @@ Definition custom_swap_back . (** [external::test_custom_swap]: forward function *) -Definition test_custom_swap_fwd +Definition test_custom_swap (x : u32) (y : u32) (st : state) : result (state * unit) := - p <- custom_swap_fwd u32 x y st; let (st0, _) := p in Return (st0, tt) + p <- custom_swap u32 x y st; let (st0, _) := p in Return (st0, tt) . (** [external::test_custom_swap]: backward function 0 *) @@ -95,9 +97,8 @@ Definition test_custom_swap_back . (** [external::test_swap_non_zero]: forward function *) -Definition test_swap_non_zero_fwd - (x : u32) (st : state) : result (state * u32) := - p <- swap_fwd u32 x 0%u32 st; +Definition test_swap_non_zero (x : u32) (st : state) : result (state * u32) := + p <- swap u32 x 0%u32 st; let (st0, _) := p in p0 <- swap_back u32 x 0%u32 st st0; let (st1, p1) := p0 in diff --git a/tests/coq/misc/External_Opaque.v b/tests/coq/misc/External_Opaque.v index d2ee42d4..80be37e7 100644 --- a/tests/coq/misc/External_Opaque.v +++ b/tests/coq/misc/External_Opaque.v @@ -11,7 +11,7 @@ Import External_Types. Module External_Opaque. (** [core::mem::swap]: forward function *) -Axiom core_mem_swap_fwd : +Axiom core_mem_swap : forall(T : Type), T -> T -> state -> result (state * unit) . @@ -26,12 +26,12 @@ Axiom core_mem_swap_back1 : . (** [core::num::nonzero::NonZeroU32::{14}::new]: forward function *) -Axiom core_num_nonzero_non_zero_u32_new_fwd - : u32 -> state -> result (state * (option Core_num_nonzero_non_zero_u32_t)) +Axiom core_num_nonzero_NonZeroU32_new + : u32 -> state -> result (state * (option core_num_nonzero_NonZeroU32_t)) . (** [core::option::Option::{0}::unwrap]: forward function *) -Axiom core_option_option_unwrap_fwd : +Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . diff --git a/tests/coq/misc/External_Types.v b/tests/coq/misc/External_Types.v index 1883fa6c..9e49ca41 100644 --- a/tests/coq/misc/External_Types.v +++ b/tests/coq/misc/External_Types.v @@ -9,7 +9,7 @@ Local Open Scope Primitives_scope. Module External_Types. (** [core::num::nonzero::NonZeroU32] *) -Axiom Core_num_nonzero_non_zero_u32_t : Type. +Axiom core_num_nonzero_NonZeroU32_t : Type. (** The state type used in the state-error monad *) Axiom state : Type. diff --git a/tests/coq/misc/Loops.v b/tests/coq/misc/Loops.v index 82e57576..1c0eab17 100644 --- a/tests/coq/misc/Loops.v +++ b/tests/coq/misc/Loops.v @@ -9,23 +9,23 @@ Local Open Scope Primitives_scope. Module Loops. (** [loops::sum]: loop 0: forward function *) -Fixpoint sum_loop_fwd (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := +Fixpoint sum_loop (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := match n with | O => Fail_ OutOfFuel | S n0 => if i s< max - then (s0 <- u32_add s i; i0 <- u32_add i 1%u32; sum_loop_fwd n0 max i0 s0) + then (s0 <- u32_add s i; i0 <- u32_add i 1%u32; sum_loop n0 max i0 s0) else u32_mul s 2%u32 end . (** [loops::sum]: forward function *) -Definition sum_fwd (n : nat) (max : u32) : result u32 := - sum_loop_fwd n max 0%u32 0%u32 +Definition sum (n : nat) (max : u32) : result u32 := + sum_loop n max 0%u32 0%u32 . (** [loops::sum_with_mut_borrows]: loop 0: forward function *) -Fixpoint sum_with_mut_borrows_loop_fwd +Fixpoint sum_with_mut_borrows_loop (n : nat) (max : u32) (mi : u32) (ms : u32) : result u32 := match n with | O => Fail_ OutOfFuel @@ -34,18 +34,18 @@ Fixpoint sum_with_mut_borrows_loop_fwd then ( ms0 <- u32_add ms mi; mi0 <- u32_add mi 1%u32; - sum_with_mut_borrows_loop_fwd n0 max mi0 ms0) + sum_with_mut_borrows_loop n0 max mi0 ms0) else u32_mul ms 2%u32 end . (** [loops::sum_with_mut_borrows]: forward function *) -Definition sum_with_mut_borrows_fwd (n : nat) (max : u32) : result u32 := - sum_with_mut_borrows_loop_fwd n max 0%u32 0%u32 +Definition sum_with_mut_borrows (n : nat) (max : u32) : result u32 := + sum_with_mut_borrows_loop n max 0%u32 0%u32 . (** [loops::sum_with_shared_borrows]: loop 0: forward function *) -Fixpoint sum_with_shared_borrows_loop_fwd +Fixpoint sum_with_shared_borrows_loop (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := match n with | O => Fail_ OutOfFuel @@ -54,87 +54,88 @@ Fixpoint sum_with_shared_borrows_loop_fwd then ( i0 <- u32_add i 1%u32; s0 <- u32_add s i0; - sum_with_shared_borrows_loop_fwd n0 max i0 s0) + sum_with_shared_borrows_loop n0 max i0 s0) else u32_mul s 2%u32 end . (** [loops::sum_with_shared_borrows]: forward function *) -Definition sum_with_shared_borrows_fwd (n : nat) (max : u32) : result u32 := - sum_with_shared_borrows_loop_fwd n max 0%u32 0%u32 +Definition sum_with_shared_borrows (n : nat) (max : u32) : result u32 := + sum_with_shared_borrows_loop n max 0%u32 0%u32 . (** [loops::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint clear_loop_fwd_back - (n : nat) (v : vec u32) (i : usize) : result (vec u32) := +Fixpoint clear_loop + (n : nat) (v : alloc_vec_Vec u32) (i : usize) : result (alloc_vec_Vec u32) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len u32 v in + let i0 := alloc_vec_Vec_len u32 v in if i s< i0 then ( i1 <- usize_add i 1%usize; - v0 <- vec_index_mut_back u32 v i 0%u32; - clear_loop_fwd_back n0 v0 i1) + v0 <- + alloc_vec_Vec_index_mut_back u32 usize + (core_slice_index_usize_coresliceindexSliceIndexInst u32) v i 0%u32; + clear_loop n0 v0 i1) else Return v end . (** [loops::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition clear_fwd_back (n : nat) (v : vec u32) : result (vec u32) := - clear_loop_fwd_back n v 0%usize +Definition clear + (n : nat) (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) := + clear_loop n v 0%usize . (** [loops::List] *) Inductive List_t (T : Type) := -| ListCons : T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _. -Arguments ListNil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [loops::list_mem]: loop 0: forward function *) -Fixpoint list_mem_loop_fwd - (n : nat) (x : u32) (ls : List_t u32) : result bool := +Fixpoint list_mem_loop (n : nat) (x : u32) (ls : List_t u32) : result bool := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons y tl => - if y s= x then Return true else list_mem_loop_fwd n0 x tl - | ListNil => Return false + | List_Cons y tl => if y s= x then Return true else list_mem_loop n0 x tl + | List_Nil => Return false end end . (** [loops::list_mem]: forward function *) -Definition list_mem_fwd (n : nat) (x : u32) (ls : List_t u32) : result bool := - list_mem_loop_fwd n x ls +Definition list_mem (n : nat) (x : u32) (ls : List_t u32) : result bool := + list_mem_loop n x ls . (** [loops::list_nth_mut_loop]: loop 0: forward function *) -Fixpoint list_nth_mut_loop_loop_fwd +Fixpoint list_nth_mut_loop_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_mut_loop_loop_fwd T n0 tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_mut_loop_loop T n0 tl i0) + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_loop]: forward function *) -Definition list_nth_mut_loop_fwd +Definition list_nth_mut_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - list_nth_mut_loop_loop_fwd T n ls i + list_nth_mut_loop_loop T n ls i . (** [loops::list_nth_mut_loop]: loop 0: backward function 0 *) @@ -146,14 +147,14 @@ Fixpoint list_nth_mut_loop_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else ( i0 <- u32_sub i 1%u32; tl0 <- list_nth_mut_loop_loop_back T n0 tl i0 ret; - Return (ListCons x tl0)) - | ListNil => Fail_ Failure + Return (List_Cons x tl0)) + | List_Nil => Fail_ Failure end end . @@ -167,46 +168,50 @@ Definition list_nth_mut_loop_back . (** [loops::list_nth_shared_loop]: loop 0: forward function *) -Fixpoint list_nth_shared_loop_loop_fwd +Fixpoint list_nth_shared_loop_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_shared_loop_loop_fwd T n0 tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_shared_loop_loop T n0 tl i0) + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_loop]: forward function *) -Definition list_nth_shared_loop_fwd +Definition list_nth_shared_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - list_nth_shared_loop_loop_fwd T n ls i + list_nth_shared_loop_loop T n ls i . (** [loops::get_elem_mut]: loop 0: forward function *) -Fixpoint get_elem_mut_loop_fwd +Fixpoint get_elem_mut_loop (n : nat) (x : usize) (ls : List_t usize) : result usize := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons y tl => - if y s= x then Return y else get_elem_mut_loop_fwd n0 x tl - | ListNil => Fail_ Failure + | List_Cons y tl => if y s= x then Return y else get_elem_mut_loop n0 x tl + | List_Nil => Fail_ Failure end end . (** [loops::get_elem_mut]: forward function *) -Definition get_elem_mut_fwd - (n : nat) (slots : vec (List_t usize)) (x : usize) : result usize := - l <- vec_index_mut_fwd (List_t usize) slots 0%usize; - get_elem_mut_loop_fwd n x l +Definition get_elem_mut + (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : + result usize + := + l <- + alloc_vec_Vec_index_mut (List_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) + slots 0%usize; + get_elem_mut_loop n x l . (** [loops::get_elem_mut]: loop 0: backward function 0 *) @@ -218,50 +223,60 @@ Fixpoint get_elem_mut_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons y tl => + | List_Cons y tl => if y s= x - then Return (ListCons ret tl) - else (tl0 <- get_elem_mut_loop_back n0 x tl ret; Return (ListCons y tl0)) - | ListNil => Fail_ Failure + then Return (List_Cons ret tl) + else ( + tl0 <- get_elem_mut_loop_back n0 x tl ret; Return (List_Cons y tl0)) + | List_Nil => Fail_ Failure end end . (** [loops::get_elem_mut]: backward function 0 *) Definition get_elem_mut_back - (n : nat) (slots : vec (List_t usize)) (x : usize) (ret : usize) : - result (vec (List_t usize)) + (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) (ret : usize) : + result (alloc_vec_Vec (List_t usize)) := - l <- vec_index_mut_fwd (List_t usize) slots 0%usize; + l <- + alloc_vec_Vec_index_mut (List_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) + slots 0%usize; l0 <- get_elem_mut_loop_back n x l ret; - vec_index_mut_back (List_t usize) slots 0%usize l0 + alloc_vec_Vec_index_mut_back (List_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) slots + 0%usize l0 . (** [loops::get_elem_shared]: loop 0: forward function *) -Fixpoint get_elem_shared_loop_fwd +Fixpoint get_elem_shared_loop (n : nat) (x : usize) (ls : List_t usize) : result usize := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons y tl => - if y s= x then Return y else get_elem_shared_loop_fwd n0 x tl - | ListNil => Fail_ Failure + | List_Cons y tl => + if y s= x then Return y else get_elem_shared_loop n0 x tl + | List_Nil => Fail_ Failure end end . (** [loops::get_elem_shared]: forward function *) -Definition get_elem_shared_fwd - (n : nat) (slots : vec (List_t usize)) (x : usize) : result usize := - l <- vec_index_fwd (List_t usize) slots 0%usize; - get_elem_shared_loop_fwd n x l +Definition get_elem_shared + (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : + result usize + := + l <- + alloc_vec_Vec_index (List_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) + slots 0%usize; + get_elem_shared_loop n x l . (** [loops::id_mut]: forward function *) -Definition id_mut_fwd (T : Type) (ls : List_t T) : result (List_t T) := - Return ls -. +Definition id_mut (T : Type) (ls : List_t T) : result (List_t T) := + Return ls. (** [loops::id_mut]: backward function 0 *) Definition id_mut_back @@ -270,31 +285,30 @@ Definition id_mut_back . (** [loops::id_shared]: forward function *) -Definition id_shared_fwd (T : Type) (ls : List_t T) : result (List_t T) := +Definition id_shared (T : Type) (ls : List_t T) : result (List_t T) := Return ls . (** [loops::list_nth_mut_loop_with_id]: loop 0: forward function *) -Fixpoint list_nth_mut_loop_with_id_loop_fwd +Fixpoint list_nth_mut_loop_with_id_loop (T : Type) (n : nat) (i : u32) (ls : List_t T) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else ( - i0 <- u32_sub i 1%u32; list_nth_mut_loop_with_id_loop_fwd T n0 i0 tl) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_mut_loop_with_id_loop T n0 i0 tl) + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_loop_with_id]: forward function *) -Definition list_nth_mut_loop_with_id_fwd +Definition list_nth_mut_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - ls0 <- id_mut_fwd T ls; list_nth_mut_loop_with_id_loop_fwd T n i ls0 + ls0 <- id_mut T ls; list_nth_mut_loop_with_id_loop T n i ls0 . (** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 *) @@ -306,14 +320,14 @@ Fixpoint list_nth_mut_loop_with_id_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else ( i0 <- u32_sub i 1%u32; tl0 <- list_nth_mut_loop_with_id_loop_back T n0 i0 tl ret; - Return (ListCons x tl0)) - | ListNil => Fail_ Failure + Return (List_Cons x tl0)) + | List_Nil => Fail_ Failure end end . @@ -323,36 +337,36 @@ Definition list_nth_mut_loop_with_id_back (T : Type) (n : nat) (ls : List_t T) (i : u32) (ret : T) : result (List_t T) := - ls0 <- id_mut_fwd T ls; + ls0 <- id_mut T ls; l <- list_nth_mut_loop_with_id_loop_back T n i ls0 ret; id_mut_back T ls l . (** [loops::list_nth_shared_loop_with_id]: loop 0: forward function *) -Fixpoint list_nth_shared_loop_with_id_loop_fwd +Fixpoint list_nth_shared_loop_with_id_loop (T : Type) (n : nat) (i : u32) (ls : List_t T) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x else ( - i0 <- u32_sub i 1%u32; list_nth_shared_loop_with_id_loop_fwd T n0 i0 tl) - | ListNil => Fail_ Failure + i0 <- u32_sub i 1%u32; list_nth_shared_loop_with_id_loop T n0 i0 tl) + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_loop_with_id]: forward function *) -Definition list_nth_shared_loop_with_id_fwd +Definition list_nth_shared_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - ls0 <- id_shared_fwd T ls; list_nth_shared_loop_with_id_loop_fwd T n i ls0 + ls0 <- id_shared T ls; list_nth_shared_loop_with_id_loop T n i ls0 . (** [loops::list_nth_mut_loop_pair]: loop 0: forward function *) -Fixpoint list_nth_mut_loop_pair_loop_fwd +Fixpoint list_nth_mut_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -360,27 +374,26 @@ Fixpoint list_nth_mut_loop_pair_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( - i0 <- u32_sub i 1%u32; - list_nth_mut_loop_pair_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + i0 <- u32_sub i 1%u32; list_nth_mut_loop_pair_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_loop_pair]: forward function *) -Definition list_nth_mut_loop_pair_fwd +Definition list_nth_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_mut_loop_pair_loop_fwd T n ls0 ls1 i + list_nth_mut_loop_pair_loop T n ls0 ls1 i . (** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 *) @@ -392,18 +405,18 @@ Fixpoint list_nth_mut_loop_pair_loop_back'a | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else ( i0 <- u32_sub i 1%u32; tl00 <- list_nth_mut_loop_pair_loop_back'a T n0 tl0 tl1 i0 ret; - Return (ListCons x0 tl00)) - | ListNil => Fail_ Failure + Return (List_Cons x0 tl00)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -425,18 +438,18 @@ Fixpoint list_nth_mut_loop_pair_loop_back'b | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else ( i0 <- u32_sub i 1%u32; tl10 <- list_nth_mut_loop_pair_loop_back'b T n0 tl0 tl1 i0 ret; - Return (ListCons x1 tl10)) - | ListNil => Fail_ Failure + Return (List_Cons x1 tl10)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -450,7 +463,7 @@ Definition list_nth_mut_loop_pair_back'b . (** [loops::list_nth_shared_loop_pair]: loop 0: forward function *) -Fixpoint list_nth_shared_loop_pair_loop_fwd +Fixpoint list_nth_shared_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -458,31 +471,30 @@ Fixpoint list_nth_shared_loop_pair_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( - i0 <- u32_sub i 1%u32; - list_nth_shared_loop_pair_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + i0 <- u32_sub i 1%u32; list_nth_shared_loop_pair_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_loop_pair]: forward function *) -Definition list_nth_shared_loop_pair_fwd +Definition list_nth_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_shared_loop_pair_loop_fwd T n ls0 ls1 i + list_nth_shared_loop_pair_loop T n ls0 ls1 i . (** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function *) -Fixpoint list_nth_mut_loop_pair_merge_loop_fwd +Fixpoint list_nth_mut_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -490,27 +502,27 @@ Fixpoint list_nth_mut_loop_pair_merge_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_mut_loop_pair_merge_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_mut_loop_pair_merge_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_loop_pair_merge]: forward function *) -Definition list_nth_mut_loop_pair_merge_fwd +Definition list_nth_mut_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_mut_loop_pair_merge_loop_fwd T n ls0 ls1 i + list_nth_mut_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 *) @@ -523,19 +535,19 @@ Fixpoint list_nth_mut_loop_pair_merge_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then let (t, t0) := ret in Return (ListCons t tl0, ListCons t0 tl1) + then let (t, t0) := ret in Return (List_Cons t tl0, List_Cons t0 tl1) else ( i0 <- u32_sub i 1%u32; p <- list_nth_mut_loop_pair_merge_loop_back T n0 tl0 tl1 i0 ret; let (tl00, tl10) := p in - Return (ListCons x0 tl00, ListCons x1 tl10)) - | ListNil => Fail_ Failure + Return (List_Cons x0 tl00, List_Cons x1 tl10)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -550,7 +562,7 @@ Definition list_nth_mut_loop_pair_merge_back . (** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function *) -Fixpoint list_nth_shared_loop_pair_merge_loop_fwd +Fixpoint list_nth_shared_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -558,31 +570,31 @@ Fixpoint list_nth_shared_loop_pair_merge_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_shared_loop_pair_merge_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_shared_loop_pair_merge_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_loop_pair_merge]: forward function *) -Definition list_nth_shared_loop_pair_merge_fwd +Definition list_nth_shared_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_shared_loop_pair_merge_loop_fwd T n ls0 ls1 i + list_nth_shared_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function *) -Fixpoint list_nth_mut_shared_loop_pair_loop_fwd +Fixpoint list_nth_mut_shared_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -590,27 +602,27 @@ Fixpoint list_nth_mut_shared_loop_pair_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_mut_shared_loop_pair_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_mut_shared_loop_pair_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_shared_loop_pair]: forward function *) -Definition list_nth_mut_shared_loop_pair_fwd +Definition list_nth_mut_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_mut_shared_loop_pair_loop_fwd T n ls0 ls1 i + list_nth_mut_shared_loop_pair_loop T n ls0 ls1 i . (** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 *) @@ -622,18 +634,18 @@ Fixpoint list_nth_mut_shared_loop_pair_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else ( i0 <- u32_sub i 1%u32; tl00 <- list_nth_mut_shared_loop_pair_loop_back T n0 tl0 tl1 i0 ret; - Return (ListCons x0 tl00)) - | ListNil => Fail_ Failure + Return (List_Cons x0 tl00)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -647,7 +659,7 @@ Definition list_nth_mut_shared_loop_pair_back . (** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function *) -Fixpoint list_nth_mut_shared_loop_pair_merge_loop_fwd +Fixpoint list_nth_mut_shared_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -655,27 +667,27 @@ Fixpoint list_nth_mut_shared_loop_pair_merge_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_mut_shared_loop_pair_merge_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_mut_shared_loop_pair_merge_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_shared_loop_pair_merge]: forward function *) -Definition list_nth_mut_shared_loop_pair_merge_fwd +Definition list_nth_mut_shared_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_mut_shared_loop_pair_merge_loop_fwd T n ls0 ls1 i + list_nth_mut_shared_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 *) @@ -687,19 +699,19 @@ Fixpoint list_nth_mut_shared_loop_pair_merge_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else ( i0 <- u32_sub i 1%u32; tl00 <- list_nth_mut_shared_loop_pair_merge_loop_back T n0 tl0 tl1 i0 ret; - Return (ListCons x0 tl00)) - | ListNil => Fail_ Failure + Return (List_Cons x0 tl00)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -713,7 +725,7 @@ Definition list_nth_mut_shared_loop_pair_merge_back . (** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function *) -Fixpoint list_nth_shared_mut_loop_pair_loop_fwd +Fixpoint list_nth_shared_mut_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -721,27 +733,27 @@ Fixpoint list_nth_shared_mut_loop_pair_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_shared_mut_loop_pair_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_shared_mut_loop_pair_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_mut_loop_pair]: forward function *) -Definition list_nth_shared_mut_loop_pair_fwd +Definition list_nth_shared_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_shared_mut_loop_pair_loop_fwd T n ls0 ls1 i + list_nth_shared_mut_loop_pair_loop T n ls0 ls1 i . (** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 *) @@ -753,18 +765,18 @@ Fixpoint list_nth_shared_mut_loop_pair_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else ( i0 <- u32_sub i 1%u32; tl10 <- list_nth_shared_mut_loop_pair_loop_back T n0 tl0 tl1 i0 ret; - Return (ListCons x1 tl10)) - | ListNil => Fail_ Failure + Return (List_Cons x1 tl10)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -778,7 +790,7 @@ Definition list_nth_shared_mut_loop_pair_back . (** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function *) -Fixpoint list_nth_shared_mut_loop_pair_merge_loop_fwd +Fixpoint list_nth_shared_mut_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -786,27 +798,27 @@ Fixpoint list_nth_shared_mut_loop_pair_merge_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_shared_mut_loop_pair_merge_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_shared_mut_loop_pair_merge_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_mut_loop_pair_merge]: forward function *) -Definition list_nth_shared_mut_loop_pair_merge_fwd +Definition list_nth_shared_mut_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_shared_mut_loop_pair_merge_loop_fwd T n ls0 ls1 i + list_nth_shared_mut_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 *) @@ -818,19 +830,19 @@ Fixpoint list_nth_shared_mut_loop_pair_merge_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else ( i0 <- u32_sub i 1%u32; tl10 <- list_nth_shared_mut_loop_pair_merge_loop_back T n0 tl0 tl1 i0 ret; - Return (ListCons x1 tl10)) - | ListNil => Fail_ Failure + Return (List_Cons x1 tl10)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index c1c24e00..c7af496f 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -9,113 +9,125 @@ Local Open Scope Primitives_scope. Module NoNestedBorrows. (** [no_nested_borrows::Pair] *) -Record Pair_t (T1 T2 : Type) := mkPair_t { Pair_x : T1; Pair_y : T2; }. +Record Pair_t (T1 T2 : Type) := mkPair_t { pair_x : T1; pair_y : T2; }. -Arguments mkPair_t {T1} {T2} _ _. -Arguments Pair_x {T1} {T2}. -Arguments Pair_y {T1} {T2}. +Arguments mkPair_t { _ _ }. +Arguments pair_x { _ _ }. +Arguments pair_y { _ _ }. (** [no_nested_borrows::List] *) Inductive List_t (T : Type) := -| ListCons : T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _. -Arguments ListNil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [no_nested_borrows::One] *) -Inductive One_t (T1 : Type) := | OneOne : T1 -> One_t T1. +Inductive One_t (T1 : Type) := | One_One : T1 -> One_t T1. -Arguments OneOne {T1} _. +Arguments One_One { _ }. (** [no_nested_borrows::EmptyEnum] *) -Inductive Empty_enum_t := | EmptyEnumEmpty : Empty_enum_t. +Inductive EmptyEnum_t := | EmptyEnum_Empty : EmptyEnum_t. (** [no_nested_borrows::Enum] *) -Inductive Enum_t := | EnumVariant1 : Enum_t | EnumVariant2 : Enum_t. +Inductive Enum_t := | Enum_Variant1 : Enum_t | Enum_Variant2 : Enum_t. (** [no_nested_borrows::EmptyStruct] *) -Record Empty_struct_t := mkEmpty_struct_t { }. +Record EmptyStruct_t := mkEmptyStruct_t { }. (** [no_nested_borrows::Sum] *) Inductive Sum_t (T1 T2 : Type) := -| SumLeft : T1 -> Sum_t T1 T2 -| SumRight : T2 -> Sum_t T1 T2 +| Sum_Left : T1 -> Sum_t T1 T2 +| Sum_Right : T2 -> Sum_t T1 T2 . -Arguments SumLeft {T1} {T2} _. -Arguments SumRight {T1} {T2} _. +Arguments Sum_Left { _ _ }. +Arguments Sum_Right { _ _ }. (** [no_nested_borrows::neg_test]: forward function *) -Definition neg_test_fwd (x : i32) : result i32 := +Definition neg_test (x : i32) : result i32 := i32_neg x. (** [no_nested_borrows::add_test]: forward function *) -Definition add_test_fwd (x : u32) (y : u32) : result u32 := +Definition add_test (x : u32) (y : u32) : result u32 := u32_add x y. (** [no_nested_borrows::subs_test]: forward function *) -Definition subs_test_fwd (x : u32) (y : u32) : result u32 := +Definition subs_test (x : u32) (y : u32) : result u32 := u32_sub x y. (** [no_nested_borrows::div_test]: forward function *) -Definition div_test_fwd (x : u32) (y : u32) : result u32 := +Definition div_test (x : u32) (y : u32) : result u32 := u32_div x y. (** [no_nested_borrows::div_test1]: forward function *) -Definition div_test1_fwd (x : u32) : result u32 := +Definition div_test1 (x : u32) : result u32 := u32_div x 2%u32. (** [no_nested_borrows::rem_test]: forward function *) -Definition rem_test_fwd (x : u32) (y : u32) : result u32 := +Definition rem_test (x : u32) (y : u32) : result u32 := u32_rem x y. +(** [no_nested_borrows::mul_test]: forward function *) +Definition mul_test (x : u32) (y : u32) : result u32 := + u32_mul x y. + +(** [no_nested_borrows::CONST0] *) +Definition const0_body : result usize := usize_add 1%usize 1%usize. +Definition const0_c : usize := const0_body%global. + +(** [no_nested_borrows::CONST1] *) +Definition const1_body : result usize := usize_mul 2%usize 2%usize. +Definition const1_c : usize := const1_body%global. + (** [no_nested_borrows::cast_test]: forward function *) -Definition cast_test_fwd (x : u32) : result i32 := +Definition cast_test (x : u32) : result i32 := scalar_cast U32 I32 x. (** [no_nested_borrows::test2]: forward function *) -Definition test2_fwd : result unit := +Definition test2 : result unit := _ <- u32_add 23%u32 44%u32; Return tt. (** Unit test for [no_nested_borrows::test2] *) -Check (test2_fwd )%return. +Check (test2 )%return. (** [no_nested_borrows::get_max]: forward function *) -Definition get_max_fwd (x : u32) (y : u32) : result u32 := +Definition get_max (x : u32) (y : u32) : result u32 := if x s>= y then Return x else Return y . (** [no_nested_borrows::test3]: forward function *) -Definition test3_fwd : result unit := - x <- get_max_fwd 4%u32 3%u32; - y <- get_max_fwd 10%u32 11%u32; +Definition test3 : result unit := + x <- get_max 4%u32 3%u32; + y <- get_max 10%u32 11%u32; z <- u32_add x y; if negb (z s= 15%u32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test3] *) -Check (test3_fwd )%return. +Check (test3 )%return. (** [no_nested_borrows::test_neg1]: forward function *) -Definition test_neg1_fwd : result unit := +Definition test_neg1 : result unit := y <- i32_neg 3%i32; if negb (y s= (-3)%i32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_neg1] *) -Check (test_neg1_fwd )%return. +Check (test_neg1 )%return. (** [no_nested_borrows::refs_test1]: forward function *) -Definition refs_test1_fwd : result unit := +Definition refs_test1 : result unit := if negb (1%i32 s= 1%i32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::refs_test1] *) -Check (refs_test1_fwd )%return. +Check (refs_test1 )%return. (** [no_nested_borrows::refs_test2]: forward function *) -Definition refs_test2_fwd : result unit := +Definition refs_test2 : result unit := if negb (2%i32 s= 2%i32) then Fail_ Failure else @@ -128,85 +140,83 @@ Definition refs_test2_fwd : result unit := . (** Unit test for [no_nested_borrows::refs_test2] *) -Check (refs_test2_fwd )%return. +Check (refs_test2 )%return. (** [no_nested_borrows::test_list1]: forward function *) -Definition test_list1_fwd : result unit := +Definition test_list1 : result unit := Return tt. (** Unit test for [no_nested_borrows::test_list1] *) -Check (test_list1_fwd )%return. +Check (test_list1 )%return. (** [no_nested_borrows::test_box1]: forward function *) -Definition test_box1_fwd : result unit := +Definition test_box1 : result unit := let b := 1%i32 in let x := b in if negb (x s= 1%i32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_box1] *) -Check (test_box1_fwd )%return. +Check (test_box1 )%return. (** [no_nested_borrows::copy_int]: forward function *) -Definition copy_int_fwd (x : i32) : result i32 := +Definition copy_int (x : i32) : result i32 := Return x. (** [no_nested_borrows::test_unreachable]: forward function *) -Definition test_unreachable_fwd (b : bool) : result unit := +Definition test_unreachable (b : bool) : result unit := if b then Fail_ Failure else Return tt . (** [no_nested_borrows::test_panic]: forward function *) -Definition test_panic_fwd (b : bool) : result unit := +Definition test_panic (b : bool) : result unit := if b then Fail_ Failure else Return tt . (** [no_nested_borrows::test_copy_int]: forward function *) -Definition test_copy_int_fwd : result unit := - y <- copy_int_fwd 0%i32; - if negb (0%i32 s= y) then Fail_ Failure else Return tt +Definition test_copy_int : result unit := + y <- copy_int 0%i32; if negb (0%i32 s= y) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_copy_int] *) -Check (test_copy_int_fwd )%return. +Check (test_copy_int )%return. (** [no_nested_borrows::is_cons]: forward function *) -Definition is_cons_fwd (T : Type) (l : List_t T) : result bool := - match l with | ListCons t l0 => Return true | ListNil => Return false end +Definition is_cons (T : Type) (l : List_t T) : result bool := + match l with | List_Cons t l0 => Return true | List_Nil => Return false end . (** [no_nested_borrows::test_is_cons]: forward function *) -Definition test_is_cons_fwd : result unit := - let l := ListNil in - b <- is_cons_fwd i32 (ListCons 0%i32 l); +Definition test_is_cons : result unit := + let l := List_Nil in + b <- is_cons i32 (List_Cons 0%i32 l); if negb b then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_is_cons] *) -Check (test_is_cons_fwd )%return. +Check (test_is_cons )%return. (** [no_nested_borrows::split_list]: forward function *) -Definition split_list_fwd - (T : Type) (l : List_t T) : result (T * (List_t T)) := +Definition split_list (T : Type) (l : List_t T) : result (T * (List_t T)) := match l with - | ListCons hd tl => Return (hd, tl) - | ListNil => Fail_ Failure + | List_Cons hd tl => Return (hd, tl) + | List_Nil => Fail_ Failure end . (** [no_nested_borrows::test_split_list]: forward function *) -Definition test_split_list_fwd : result unit := - let l := ListNil in - p <- split_list_fwd i32 (ListCons 0%i32 l); +Definition test_split_list : result unit := + let l := List_Nil in + p <- split_list i32 (List_Cons 0%i32 l); let (hd, _) := p in if negb (hd s= 0%i32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_split_list] *) -Check (test_split_list_fwd )%return. +Check (test_split_list )%return. (** [no_nested_borrows::choose]: forward function *) -Definition choose_fwd (T : Type) (b : bool) (x : T) (y : T) : result T := +Definition choose (T : Type) (b : bool) (x : T) (y : T) : result T := if b then Return x else Return y . @@ -217,8 +227,8 @@ Definition choose_back . (** [no_nested_borrows::choose_test]: forward function *) -Definition choose_test_fwd : result unit := - z <- choose_fwd i32 true 0%i32 0%i32; +Definition choose_test : result unit := + z <- choose i32 true 0%i32 0%i32; z0 <- i32_add z 1%i32; if negb (z0 s= 1%i32) then Fail_ Failure @@ -231,57 +241,56 @@ Definition choose_test_fwd : result unit := . (** Unit test for [no_nested_borrows::choose_test] *) -Check (choose_test_fwd )%return. +Check (choose_test )%return. (** [no_nested_borrows::test_char]: forward function *) -Definition test_char_fwd : result char := - Return (char_of_byte Coq.Init.Byte.x61) -. +Definition test_char : result char := + Return (char_of_byte Coq.Init.Byte.x61). (** [no_nested_borrows::Tree] *) Inductive Tree_t (T : Type) := -| TreeLeaf : T -> Tree_t T -| TreeNode : T -> Node_elem_t T -> Tree_t T -> Tree_t T +| Tree_Leaf : T -> Tree_t T +| Tree_Node : T -> NodeElem_t T -> Tree_t T -> Tree_t T (** [no_nested_borrows::NodeElem] *) -with Node_elem_t (T : Type) := -| NodeElemCons : Tree_t T -> Node_elem_t T -> Node_elem_t T -| NodeElemNil : Node_elem_t T +with NodeElem_t (T : Type) := +| NodeElem_Cons : Tree_t T -> NodeElem_t T -> NodeElem_t T +| NodeElem_Nil : NodeElem_t T . -Arguments TreeLeaf {T} _. -Arguments TreeNode {T} _ _ _. +Arguments Tree_Leaf { _ }. +Arguments Tree_Node { _ }. -Arguments NodeElemCons {T} _ _. -Arguments NodeElemNil {T}. +Arguments NodeElem_Cons { _ }. +Arguments NodeElem_Nil { _ }. (** [no_nested_borrows::list_length]: forward function *) -Fixpoint list_length_fwd (T : Type) (l : List_t T) : result u32 := +Fixpoint list_length (T : Type) (l : List_t T) : result u32 := match l with - | ListCons t l1 => i <- list_length_fwd T l1; u32_add 1%u32 i - | ListNil => Return 0%u32 + | List_Cons t l1 => i <- list_length T l1; u32_add 1%u32 i + | List_Nil => Return 0%u32 end . (** [no_nested_borrows::list_nth_shared]: forward function *) -Fixpoint list_nth_shared_fwd (T : Type) (l : List_t T) (i : u32) : result T := +Fixpoint list_nth_shared (T : Type) (l : List_t T) (i : u32) : result T := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_shared_fwd T tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_shared T tl i0) + | List_Nil => Fail_ Failure end . (** [no_nested_borrows::list_nth_mut]: forward function *) -Fixpoint list_nth_mut_fwd (T : Type) (l : List_t T) (i : u32) : result T := +Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_mut_fwd T tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_mut T tl i0) + | List_Nil => Fail_ Failure end . @@ -289,73 +298,72 @@ Fixpoint list_nth_mut_fwd (T : Type) (l : List_t T) (i : u32) : result T := Fixpoint list_nth_mut_back (T : Type) (l : List_t T) (i : u32) (ret : T) : result (List_t T) := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else ( i0 <- u32_sub i 1%u32; tl0 <- list_nth_mut_back T tl i0 ret; - Return (ListCons x tl0)) - | ListNil => Fail_ Failure + Return (List_Cons x tl0)) + | List_Nil => Fail_ Failure end . (** [no_nested_borrows::list_rev_aux]: forward function *) -Fixpoint list_rev_aux_fwd +Fixpoint list_rev_aux (T : Type) (li : List_t T) (lo : List_t T) : result (List_t T) := match li with - | ListCons hd tl => list_rev_aux_fwd T tl (ListCons hd lo) - | ListNil => Return lo + | List_Cons hd tl => list_rev_aux T tl (List_Cons hd lo) + | List_Nil => Return lo end . (** [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition list_rev_fwd_back (T : Type) (l : List_t T) : result (List_t T) := - let li := mem_replace_fwd (List_t T) l ListNil in - list_rev_aux_fwd T li ListNil +Definition list_rev (T : Type) (l : List_t T) : result (List_t T) := + let li := core_mem_replace (List_t T) l List_Nil in + list_rev_aux T li List_Nil . (** [no_nested_borrows::test_list_functions]: forward function *) -Definition test_list_functions_fwd : result unit := - let l := ListNil in - let l0 := ListCons 2%i32 l in - let l1 := ListCons 1%i32 l0 in - i <- list_length_fwd i32 (ListCons 0%i32 l1); +Definition test_list_functions : result unit := + let l := List_Nil in + let l0 := List_Cons 2%i32 l in + let l1 := List_Cons 1%i32 l0 in + i <- list_length i32 (List_Cons 0%i32 l1); if negb (i s= 3%u32) then Fail_ Failure else ( - i0 <- list_nth_shared_fwd i32 (ListCons 0%i32 l1) 0%u32; + i0 <- list_nth_shared i32 (List_Cons 0%i32 l1) 0%u32; if negb (i0 s= 0%i32) then Fail_ Failure else ( - i1 <- list_nth_shared_fwd i32 (ListCons 0%i32 l1) 1%u32; + i1 <- list_nth_shared i32 (List_Cons 0%i32 l1) 1%u32; if negb (i1 s= 1%i32) then Fail_ Failure else ( - i2 <- list_nth_shared_fwd i32 (ListCons 0%i32 l1) 2%u32; + i2 <- list_nth_shared i32 (List_Cons 0%i32 l1) 2%u32; if negb (i2 s= 2%i32) then Fail_ Failure else ( - ls <- list_nth_mut_back i32 (ListCons 0%i32 l1) 1%u32 3%i32; - i3 <- list_nth_shared_fwd i32 ls 0%u32; + ls <- list_nth_mut_back i32 (List_Cons 0%i32 l1) 1%u32 3%i32; + i3 <- list_nth_shared i32 ls 0%u32; if negb (i3 s= 0%i32) then Fail_ Failure else ( - i4 <- list_nth_shared_fwd i32 ls 1%u32; + i4 <- list_nth_shared i32 ls 1%u32; if negb (i4 s= 3%i32) then Fail_ Failure else ( - i5 <- list_nth_shared_fwd i32 ls 2%u32; + i5 <- list_nth_shared i32 ls 2%u32; if negb (i5 s= 2%i32) then Fail_ Failure else Return tt)))))) . (** Unit test for [no_nested_borrows::test_list_functions] *) -Check (test_list_functions_fwd )%return. +Check (test_list_functions )%return. (** [no_nested_borrows::id_mut_pair1]: forward function *) -Definition id_mut_pair1_fwd - (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := +Definition id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := Return (x, y) . @@ -366,8 +374,7 @@ Definition id_mut_pair1_back . (** [no_nested_borrows::id_mut_pair2]: forward function *) -Definition id_mut_pair2_fwd - (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := +Definition id_mut_pair2 (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := let (t, t0) := p in Return (t, t0) . @@ -378,8 +385,7 @@ Definition id_mut_pair2_back . (** [no_nested_borrows::id_mut_pair3]: forward function *) -Definition id_mut_pair3_fwd - (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := +Definition id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := Return (x, y) . @@ -396,8 +402,7 @@ Definition id_mut_pair3_back'b . (** [no_nested_borrows::id_mut_pair4]: forward function *) -Definition id_mut_pair4_fwd - (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := +Definition id_mut_pair4 (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := let (t, t0) := p in Return (t, t0) . @@ -414,101 +419,101 @@ Definition id_mut_pair4_back'b . (** [no_nested_borrows::StructWithTuple] *) -Record Struct_with_tuple_t (T1 T2 : Type) := -mkStruct_with_tuple_t { - Struct_with_tuple_p : (T1 * T2); +Record StructWithTuple_t (T1 T2 : Type) := +mkStructWithTuple_t { + structWithTuple_p : (T1 * T2); } . -Arguments mkStruct_with_tuple_t {T1} {T2} _. -Arguments Struct_with_tuple_p {T1} {T2}. +Arguments mkStructWithTuple_t { _ _ }. +Arguments structWithTuple_p { _ _ }. (** [no_nested_borrows::new_tuple1]: forward function *) -Definition new_tuple1_fwd : result (Struct_with_tuple_t u32 u32) := - Return {| Struct_with_tuple_p := (1%u32, 2%u32) |} +Definition new_tuple1 : result (StructWithTuple_t u32 u32) := + Return {| structWithTuple_p := (1%u32, 2%u32) |} . (** [no_nested_borrows::new_tuple2]: forward function *) -Definition new_tuple2_fwd : result (Struct_with_tuple_t i16 i16) := - Return {| Struct_with_tuple_p := (1%i16, 2%i16) |} +Definition new_tuple2 : result (StructWithTuple_t i16 i16) := + Return {| structWithTuple_p := (1%i16, 2%i16) |} . (** [no_nested_borrows::new_tuple3]: forward function *) -Definition new_tuple3_fwd : result (Struct_with_tuple_t u64 i64) := - Return {| Struct_with_tuple_p := (1%u64, 2%i64) |} +Definition new_tuple3 : result (StructWithTuple_t u64 i64) := + Return {| structWithTuple_p := (1%u64, 2%i64) |} . (** [no_nested_borrows::StructWithPair] *) -Record Struct_with_pair_t (T1 T2 : Type) := -mkStruct_with_pair_t { - Struct_with_pair_p : Pair_t T1 T2; +Record StructWithPair_t (T1 T2 : Type) := +mkStructWithPair_t { + structWithPair_p : Pair_t T1 T2; } . -Arguments mkStruct_with_pair_t {T1} {T2} _. -Arguments Struct_with_pair_p {T1} {T2}. +Arguments mkStructWithPair_t { _ _ }. +Arguments structWithPair_p { _ _ }. (** [no_nested_borrows::new_pair1]: forward function *) -Definition new_pair1_fwd : result (Struct_with_pair_t u32 u32) := - Return {| Struct_with_pair_p := {| Pair_x := 1%u32; Pair_y := 2%u32 |} |} +Definition new_pair1 : result (StructWithPair_t u32 u32) := + Return {| structWithPair_p := {| pair_x := 1%u32; pair_y := 2%u32 |} |} . (** [no_nested_borrows::test_constants]: forward function *) -Definition test_constants_fwd : result unit := - swt <- new_tuple1_fwd; - let (i, _) := swt.(Struct_with_tuple_p) in +Definition test_constants : result unit := + swt <- new_tuple1; + let (i, _) := swt.(structWithTuple_p) in if negb (i s= 1%u32) then Fail_ Failure else ( - swt0 <- new_tuple2_fwd; - let (i0, _) := swt0.(Struct_with_tuple_p) in + swt0 <- new_tuple2; + let (i0, _) := swt0.(structWithTuple_p) in if negb (i0 s= 1%i16) then Fail_ Failure else ( - swt1 <- new_tuple3_fwd; - let (i1, _) := swt1.(Struct_with_tuple_p) in + swt1 <- new_tuple3; + let (i1, _) := swt1.(structWithTuple_p) in if negb (i1 s= 1%u64) then Fail_ Failure else ( - swp <- new_pair1_fwd; - if negb (swp.(Struct_with_pair_p).(Pair_x) s= 1%u32) + swp <- new_pair1; + if negb (swp.(structWithPair_p).(pair_x) s= 1%u32) then Fail_ Failure else Return tt))) . (** Unit test for [no_nested_borrows::test_constants] *) -Check (test_constants_fwd )%return. +Check (test_constants )%return. (** [no_nested_borrows::test_weird_borrows1]: forward function *) -Definition test_weird_borrows1_fwd : result unit := +Definition test_weird_borrows1 : result unit := Return tt. (** Unit test for [no_nested_borrows::test_weird_borrows1] *) -Check (test_weird_borrows1_fwd )%return. +Check (test_weird_borrows1 )%return. (** [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition test_mem_replace_fwd_back (px : u32) : result u32 := - let y := mem_replace_fwd u32 px 1%u32 in +Definition test_mem_replace (px : u32) : result u32 := + let y := core_mem_replace u32 px 1%u32 in if negb (y s= 0%u32) then Fail_ Failure else Return 2%u32 . (** [no_nested_borrows::test_shared_borrow_bool1]: forward function *) -Definition test_shared_borrow_bool1_fwd (b : bool) : result u32 := +Definition test_shared_borrow_bool1 (b : bool) : result u32 := if b then Return 0%u32 else Return 1%u32 . (** [no_nested_borrows::test_shared_borrow_bool2]: forward function *) -Definition test_shared_borrow_bool2_fwd : result u32 := +Definition test_shared_borrow_bool2 : result u32 := Return 0%u32. (** [no_nested_borrows::test_shared_borrow_enum1]: forward function *) -Definition test_shared_borrow_enum1_fwd (l : List_t u32) : result u32 := - match l with | ListCons i l0 => Return 1%u32 | ListNil => Return 0%u32 end +Definition test_shared_borrow_enum1 (l : List_t u32) : result u32 := + match l with | List_Cons i l0 => Return 1%u32 | List_Nil => Return 0%u32 end . (** [no_nested_borrows::test_shared_borrow_enum2]: forward function *) -Definition test_shared_borrow_enum2_fwd : result u32 := +Definition test_shared_borrow_enum2 : result u32 := Return 0%u32. End NoNestedBorrows . diff --git a/tests/coq/misc/Paper.v b/tests/coq/misc/Paper.v index 175a523d..d3852e6b 100644 --- a/tests/coq/misc/Paper.v +++ b/tests/coq/misc/Paper.v @@ -10,20 +10,19 @@ Module Paper. (** [paper::ref_incr]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition ref_incr_fwd_back (x : i32) : result i32 := +Definition ref_incr (x : i32) : result i32 := i32_add x 1%i32. (** [paper::test_incr]: forward function *) -Definition test_incr_fwd : result unit := - x <- ref_incr_fwd_back 0%i32; - if negb (x s= 1%i32) then Fail_ Failure else Return tt +Definition test_incr : result unit := + x <- ref_incr 0%i32; if negb (x s= 1%i32) then Fail_ Failure else Return tt . (** Unit test for [paper::test_incr] *) -Check (test_incr_fwd )%return. +Check (test_incr )%return. (** [paper::choose]: forward function *) -Definition choose_fwd (T : Type) (b : bool) (x : T) (y : T) : result T := +Definition choose (T : Type) (b : bool) (x : T) (y : T) : result T := if b then Return x else Return y . @@ -34,8 +33,8 @@ Definition choose_back . (** [paper::test_choose]: forward function *) -Definition test_choose_fwd : result unit := - z <- choose_fwd i32 true 0%i32 0%i32; +Definition test_choose : result unit := + z <- choose i32 true 0%i32 0%i32; z0 <- i32_add z 1%i32; if negb (z0 s= 1%i32) then Fail_ Failure @@ -48,25 +47,25 @@ Definition test_choose_fwd : result unit := . (** Unit test for [paper::test_choose] *) -Check (test_choose_fwd )%return. +Check (test_choose )%return. (** [paper::List] *) Inductive List_t (T : Type) := -| ListCons : T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _. -Arguments ListNil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [paper::list_nth_mut]: forward function *) -Fixpoint list_nth_mut_fwd (T : Type) (l : List_t T) (i : u32) : result T := +Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_mut_fwd T tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_mut T tl i0) + | List_Nil => Fail_ Failure end . @@ -74,44 +73,44 @@ Fixpoint list_nth_mut_fwd (T : Type) (l : List_t T) (i : u32) : result T := Fixpoint list_nth_mut_back (T : Type) (l : List_t T) (i : u32) (ret : T) : result (List_t T) := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else ( i0 <- u32_sub i 1%u32; tl0 <- list_nth_mut_back T tl i0 ret; - Return (ListCons x tl0)) - | ListNil => Fail_ Failure + Return (List_Cons x tl0)) + | List_Nil => Fail_ Failure end . (** [paper::sum]: forward function *) -Fixpoint sum_fwd (l : List_t i32) : result i32 := +Fixpoint sum (l : List_t i32) : result i32 := match l with - | ListCons x tl => i <- sum_fwd tl; i32_add x i - | ListNil => Return 0%i32 + | List_Cons x tl => i <- sum tl; i32_add x i + | List_Nil => Return 0%i32 end . (** [paper::test_nth]: forward function *) -Definition test_nth_fwd : result unit := - let l := ListNil in - let l0 := ListCons 3%i32 l in - let l1 := ListCons 2%i32 l0 in - x <- list_nth_mut_fwd i32 (ListCons 1%i32 l1) 2%u32; +Definition test_nth : result unit := + let l := List_Nil in + let l0 := List_Cons 3%i32 l in + let l1 := List_Cons 2%i32 l0 in + x <- list_nth_mut i32 (List_Cons 1%i32 l1) 2%u32; x0 <- i32_add x 1%i32; - l2 <- list_nth_mut_back i32 (ListCons 1%i32 l1) 2%u32 x0; - i <- sum_fwd l2; + l2 <- list_nth_mut_back i32 (List_Cons 1%i32 l1) 2%u32 x0; + i <- sum l2; if negb (i s= 7%i32) then Fail_ Failure else Return tt . (** Unit test for [paper::test_nth] *) -Check (test_nth_fwd )%return. +Check (test_nth )%return. (** [paper::call_choose]: forward function *) -Definition call_choose_fwd (p : (u32 * u32)) : result u32 := +Definition call_choose (p : (u32 * u32)) : result u32 := let (px, py) := p in - pz <- choose_fwd u32 true px py; + pz <- choose u32 true px py; pz0 <- u32_add pz 1%u32; p0 <- choose_back u32 true px py pz0; let (px0, _) := p0 in diff --git a/tests/coq/misc/PoloniusList.v b/tests/coq/misc/PoloniusList.v index 54021bdf..4848444f 100644 --- a/tests/coq/misc/PoloniusList.v +++ b/tests/coq/misc/PoloniusList.v @@ -10,19 +10,19 @@ Module PoloniusList. (** [polonius_list::List] *) Inductive List_t (T : Type) := -| ListCons : T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _. -Arguments ListNil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [polonius_list::get_list_at_x]: forward function *) -Fixpoint get_list_at_x_fwd (ls : List_t u32) (x : u32) : result (List_t u32) := +Fixpoint get_list_at_x (ls : List_t u32) (x : u32) : result (List_t u32) := match ls with - | ListCons hd tl => - if hd s= x then Return (ListCons hd tl) else get_list_at_x_fwd tl x - | ListNil => Return ListNil + | List_Cons hd tl => + if hd s= x then Return (List_Cons hd tl) else get_list_at_x tl x + | List_Nil => Return List_Nil end . @@ -30,11 +30,11 @@ Fixpoint get_list_at_x_fwd (ls : List_t u32) (x : u32) : result (List_t u32) := Fixpoint get_list_at_x_back (ls : List_t u32) (x : u32) (ret : List_t u32) : result (List_t u32) := match ls with - | ListCons hd tl => + | List_Cons hd tl => if hd s= x then Return ret - else (tl0 <- get_list_at_x_back tl x ret; Return (ListCons hd tl0)) - | ListNil => Return ret + else (tl0 <- get_list_at_x_back tl x ret; Return (List_Cons hd tl0)) + | List_Nil => Return ret end . diff --git a/tests/coq/misc/Primitives.v b/tests/coq/misc/Primitives.v index 71a2d9c3..85e38f01 100644 --- a/tests/coq/misc/Primitives.v +++ b/tests/coq/misc/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -394,12 +396,89 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -419,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -474,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. +Definition alloc_vec_Vec_insert_fwd (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result unit := + if to_Z i <? alloc_vec_Vec_length v then Return tt else Fail_ Failure. -Definition vec_insert_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i <? Z.of_nat (length l) then Return (list_update l (usize_to_nat i) x) else Fail_ Failure). -(* The **backward** function shouldn't be used *) -Definition vec_index_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i <? vec_length v then Return tt else Fail_ Failure. - -(* The **backward** function shouldn't be used *) -Definition vec_index_mut_fwd (T: Type) (v: vec T) (i: usize) : result T := - match nth_error (vec_to_list v) (usize_to_nat i) with - | Some n => Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i <? Z.of_nat (length l) - then Return (list_update l (usize_to_nat i) x) - else Fail_ Failure). +(* [core::slice::index::Range:::get]: forward function *) +Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: forward function *) +Axiom core_slice_index_Range_get_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/traits/Makefile b/tests/coq/traits/Makefile new file mode 100644 index 00000000..1a5aee4a --- /dev/null +++ b/tests/coq/traits/Makefile @@ -0,0 +1,23 @@ +# This file was automatically generated - modify ../Makefile.template instead +# Makefile originally taken from coq-club + +%: Makefile.coq phony + +make -f Makefile.coq $@ + +all: Makefile.coq + +make -f Makefile.coq all + +clean: Makefile.coq + +make -f Makefile.coq clean + rm -f Makefile.coq + +Makefile.coq: _CoqProject Makefile + coq_makefile -f _CoqProject | sed 's/$$(COQCHK) $$(COQCHKFLAGS) $$(COQLIBS)/$$(COQCHK) $$(COQCHKFLAGS) $$(subst -Q,-R,$$(COQLIBS))/' > Makefile.coq + +_CoqProject: ; + +Makefile: ; + +phony: ; + +.PHONY: all clean phony diff --git a/tests/coq/traits/Primitives.v b/tests/coq/traits/Primitives.v new file mode 100644 index 00000000..85e38f01 --- /dev/null +++ b/tests/coq/traits/Primitives.v @@ -0,0 +1,822 @@ +Require Import Lia. +Require Coq.Strings.Ascii. +Require Coq.Strings.String. +Require Import Coq.Program.Equality. +Require Import Coq.ZArith.ZArith. +Require Import Coq.ZArith.Znat. +Require Import List. +Import ListNotations. + +Module Primitives. + + (* TODO: use more *) +Declare Scope Primitives_scope. + +(*** Result *) + +Inductive error := + | Failure + | OutOfFuel. + +Inductive result A := + | Return : A -> result A + | Fail_ : error -> result A. + +Arguments Return {_} a. +Arguments Fail_ {_}. + +Definition bind {A B} (m: result A) (f: A -> result B) : result B := + match m with + | Fail_ e => Fail_ e + | Return x => f x + end. + +Definition return_ {A: Type} (x: A) : result A := Return x. +Definition fail_ {A: Type} (e: error) : result A := Fail_ e. + +Notation "x <- c1 ; c2" := (bind c1 (fun x => c2)) + (at level 61, c1 at next level, right associativity). + +(** Monadic assert *) +Definition massert (b: bool) : result unit := + if b then Return tt else Fail_ Failure. + +(** Normalize and unwrap a successful result (used for globals) *) +Definition eval_result_refl {A} {x} (a: result A) (p: a = Return x) : A := + match a as r return (r = Return x -> A) with + | Return a' => fun _ => a' + | Fail_ e => fun p' => + False_rect _ (eq_ind (Fail_ e) + (fun e : result A => + match e with + | Return _ => False + | Fail_ e => True + end) + I (Return x) p') + end p. + +Notation "x %global" := (eval_result_refl x eq_refl) (at level 40). +Notation "x %return" := (eval_result_refl x eq_refl) (at level 40). + +(* Sanity check *) +Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. + +(*** Misc *) + +Definition string := Coq.Strings.String.string. +Definition char := Coq.Strings.Ascii.ascii. +Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. + +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. + +(*** Scalars *) + +Definition i8_min : Z := -128%Z. +Definition i8_max : Z := 127%Z. +Definition i16_min : Z := -32768%Z. +Definition i16_max : Z := 32767%Z. +Definition i32_min : Z := -2147483648%Z. +Definition i32_max : Z := 2147483647%Z. +Definition i64_min : Z := -9223372036854775808%Z. +Definition i64_max : Z := 9223372036854775807%Z. +Definition i128_min : Z := -170141183460469231731687303715884105728%Z. +Definition i128_max : Z := 170141183460469231731687303715884105727%Z. +Definition u8_min : Z := 0%Z. +Definition u8_max : Z := 255%Z. +Definition u16_min : Z := 0%Z. +Definition u16_max : Z := 65535%Z. +Definition u32_min : Z := 0%Z. +Definition u32_max : Z := 4294967295%Z. +Definition u64_min : Z := 0%Z. +Definition u64_max : Z := 18446744073709551615%Z. +Definition u128_min : Z := 0%Z. +Definition u128_max : Z := 340282366920938463463374607431768211455%Z. + +(** The bounds of [isize] and [usize] vary with the architecture. *) +Axiom isize_min : Z. +Axiom isize_max : Z. +Definition usize_min : Z := 0%Z. +Axiom usize_max : Z. + +Open Scope Z_scope. + +(** We provide those lemmas to reason about the bounds of [isize] and [usize] *) +Axiom isize_min_bound : isize_min <= i32_min. +Axiom isize_max_bound : i32_max <= isize_max. +Axiom usize_max_bound : u32_max <= usize_max. + +Inductive scalar_ty := + | Isize + | I8 + | I16 + | I32 + | I64 + | I128 + | Usize + | U8 + | U16 + | U32 + | U64 + | U128 +. + +Definition scalar_min (ty: scalar_ty) : Z := + match ty with + | Isize => isize_min + | I8 => i8_min + | I16 => i16_min + | I32 => i32_min + | I64 => i64_min + | I128 => i128_min + | Usize => usize_min + | U8 => u8_min + | U16 => u16_min + | U32 => u32_min + | U64 => u64_min + | U128 => u128_min +end. + +Definition scalar_max (ty: scalar_ty) : Z := + match ty with + | Isize => isize_max + | I8 => i8_max + | I16 => i16_max + | I32 => i32_max + | I64 => i64_max + | I128 => i128_max + | Usize => usize_max + | U8 => u8_max + | U16 => u16_max + | U32 => u32_max + | U64 => u64_max + | U128 => u128_max +end. + +(** We use the following conservative bounds to make sure we can compute bound + checks in most situations *) +Definition scalar_min_cons (ty: scalar_ty) : Z := + match ty with + | Isize => i32_min + | Usize => u32_min + | _ => scalar_min ty +end. + +Definition scalar_max_cons (ty: scalar_ty) : Z := + match ty with + | Isize => i32_max + | Usize => u32_max + | _ => scalar_max ty +end. + +Lemma scalar_min_cons_valid : forall ty, scalar_min ty <= scalar_min_cons ty . +Proof. + destruct ty; unfold scalar_min_cons, scalar_min; try lia. + - pose isize_min_bound; lia. + - apply Z.le_refl. +Qed. + +Lemma scalar_max_cons_valid : forall ty, scalar_max ty >= scalar_max_cons ty . +Proof. + destruct ty; unfold scalar_max_cons, scalar_max; try lia. + - pose isize_max_bound; lia. + - pose usize_max_bound. lia. +Qed. + +Definition scalar (ty: scalar_ty) : Type := + { x: Z | scalar_min ty <= x <= scalar_max ty }. + +Definition to_Z {ty} (x: scalar ty) : Z := proj1_sig x. + +(** Bounds checks: we start by using the conservative bounds, to make sure we + can compute in most situations, then we use the real bounds (for [isize] + and [usize]). *) +Definition scalar_ge_min (ty: scalar_ty) (x: Z) : bool := + Z.leb (scalar_min_cons ty) x || Z.leb (scalar_min ty) x. + +Definition scalar_le_max (ty: scalar_ty) (x: Z) : bool := + Z.leb x (scalar_max_cons ty) || Z.leb x (scalar_max ty). + +Lemma scalar_ge_min_valid (ty: scalar_ty) (x: Z) : + scalar_ge_min ty x = true -> scalar_min ty <= x . +Proof. + unfold scalar_ge_min. + pose (scalar_min_cons_valid ty). + lia. +Qed. + +Lemma scalar_le_max_valid (ty: scalar_ty) (x: Z) : + scalar_le_max ty x = true -> x <= scalar_max ty . +Proof. + unfold scalar_le_max. + pose (scalar_max_cons_valid ty). + lia. +Qed. + +Definition scalar_in_bounds (ty: scalar_ty) (x: Z) : bool := + scalar_ge_min ty x && scalar_le_max ty x . + +Lemma scalar_in_bounds_valid (ty: scalar_ty) (x: Z) : + scalar_in_bounds ty x = true -> scalar_min ty <= x <= scalar_max ty . +Proof. + unfold scalar_in_bounds. + intros H. + destruct (scalar_ge_min ty x) eqn:Hmin. + - destruct (scalar_le_max ty x) eqn:Hmax. + + pose (scalar_ge_min_valid ty x Hmin). + pose (scalar_le_max_valid ty x Hmax). + lia. + + inversion H. + - inversion H. +Qed. + +Import Sumbool. + +Definition mk_scalar (ty: scalar_ty) (x: Z) : result (scalar ty) := + match sumbool_of_bool (scalar_in_bounds ty x) with + | left H => Return (exist _ x (scalar_in_bounds_valid _ _ H)) + | right _ => Fail_ Failure + end. + +Definition scalar_add {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty (to_Z x + to_Z y). + +Definition scalar_sub {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty (to_Z x - to_Z y). + +Definition scalar_mul {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty (to_Z x * to_Z y). + +Definition scalar_div {ty} (x y: scalar ty) : result (scalar ty) := + if to_Z y =? 0 then Fail_ Failure else + mk_scalar ty (to_Z x / to_Z y). + +Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty (Z.rem (to_Z x) (to_Z y)). + +Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). + +(** Cast an integer from a [src_ty] to a [tgt_ty] *) +(* TODO: check the semantics of casts in Rust *) +Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := + mk_scalar tgt_ty (to_Z x). + +(** Comparisons *) +Definition scalar_leb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.leb (to_Z x) (to_Z y) . + +Definition scalar_ltb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.ltb (to_Z x) (to_Z y) . + +Definition scalar_geb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.geb (to_Z x) (to_Z y) . + +Definition scalar_gtb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.gtb (to_Z x) (to_Z y) . + +Definition scalar_eqb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.eqb (to_Z x) (to_Z y) . + +Definition scalar_neqb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + negb (Z.eqb (to_Z x) (to_Z y)) . + + +(** The scalar types *) +Definition isize := scalar Isize. +Definition i8 := scalar I8. +Definition i16 := scalar I16. +Definition i32 := scalar I32. +Definition i64 := scalar I64. +Definition i128 := scalar I128. +Definition usize := scalar Usize. +Definition u8 := scalar U8. +Definition u16 := scalar U16. +Definition u32 := scalar U32. +Definition u64 := scalar U64. +Definition u128 := scalar U128. + +(** Negaion *) +Definition isize_neg := @scalar_neg Isize. +Definition i8_neg := @scalar_neg I8. +Definition i16_neg := @scalar_neg I16. +Definition i32_neg := @scalar_neg I32. +Definition i64_neg := @scalar_neg I64. +Definition i128_neg := @scalar_neg I128. + +(** Division *) +Definition isize_div := @scalar_div Isize. +Definition i8_div := @scalar_div I8. +Definition i16_div := @scalar_div I16. +Definition i32_div := @scalar_div I32. +Definition i64_div := @scalar_div I64. +Definition i128_div := @scalar_div I128. +Definition usize_div := @scalar_div Usize. +Definition u8_div := @scalar_div U8. +Definition u16_div := @scalar_div U16. +Definition u32_div := @scalar_div U32. +Definition u64_div := @scalar_div U64. +Definition u128_div := @scalar_div U128. + +(** Remainder *) +Definition isize_rem := @scalar_rem Isize. +Definition i8_rem := @scalar_rem I8. +Definition i16_rem := @scalar_rem I16. +Definition i32_rem := @scalar_rem I32. +Definition i64_rem := @scalar_rem I64. +Definition i128_rem := @scalar_rem I128. +Definition usize_rem := @scalar_rem Usize. +Definition u8_rem := @scalar_rem U8. +Definition u16_rem := @scalar_rem U16. +Definition u32_rem := @scalar_rem U32. +Definition u64_rem := @scalar_rem U64. +Definition u128_rem := @scalar_rem U128. + +(** Addition *) +Definition isize_add := @scalar_add Isize. +Definition i8_add := @scalar_add I8. +Definition i16_add := @scalar_add I16. +Definition i32_add := @scalar_add I32. +Definition i64_add := @scalar_add I64. +Definition i128_add := @scalar_add I128. +Definition usize_add := @scalar_add Usize. +Definition u8_add := @scalar_add U8. +Definition u16_add := @scalar_add U16. +Definition u32_add := @scalar_add U32. +Definition u64_add := @scalar_add U64. +Definition u128_add := @scalar_add U128. + +(** Substraction *) +Definition isize_sub := @scalar_sub Isize. +Definition i8_sub := @scalar_sub I8. +Definition i16_sub := @scalar_sub I16. +Definition i32_sub := @scalar_sub I32. +Definition i64_sub := @scalar_sub I64. +Definition i128_sub := @scalar_sub I128. +Definition usize_sub := @scalar_sub Usize. +Definition u8_sub := @scalar_sub U8. +Definition u16_sub := @scalar_sub U16. +Definition u32_sub := @scalar_sub U32. +Definition u64_sub := @scalar_sub U64. +Definition u128_sub := @scalar_sub U128. + +(** Multiplication *) +Definition isize_mul := @scalar_mul Isize. +Definition i8_mul := @scalar_mul I8. +Definition i16_mul := @scalar_mul I16. +Definition i32_mul := @scalar_mul I32. +Definition i64_mul := @scalar_mul I64. +Definition i128_mul := @scalar_mul I128. +Definition usize_mul := @scalar_mul Usize. +Definition u8_mul := @scalar_mul U8. +Definition u16_mul := @scalar_mul U16. +Definition u32_mul := @scalar_mul U32. +Definition u64_mul := @scalar_mul U64. +Definition u128_mul := @scalar_mul U128. + +(** Small utility *) +Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). + +(** Notations *) +Notation "x %isize" := ((mk_scalar Isize x)%return) (at level 9). +Notation "x %i8" := ((mk_scalar I8 x)%return) (at level 9). +Notation "x %i16" := ((mk_scalar I16 x)%return) (at level 9). +Notation "x %i32" := ((mk_scalar I32 x)%return) (at level 9). +Notation "x %i64" := ((mk_scalar I64 x)%return) (at level 9). +Notation "x %i128" := ((mk_scalar I128 x)%return) (at level 9). +Notation "x %usize" := ((mk_scalar Usize x)%return) (at level 9). +Notation "x %u8" := ((mk_scalar U8 x)%return) (at level 9). +Notation "x %u16" := ((mk_scalar U16 x)%return) (at level 9). +Notation "x %u32" := ((mk_scalar U32 x)%return) (at level 9). +Notation "x %u64" := ((mk_scalar U64 x)%return) (at level 9). +Notation "x %u128" := ((mk_scalar U128 x)%return) (at level 9). + +Notation "x s= y" := (scalar_eqb x y) (at level 80) : Primitives_scope. +Notation "x s<> y" := (scalar_neqb x y) (at level 80) : Primitives_scope. +Notation "x s<= y" := (scalar_leb x y) (at level 80) : Primitives_scope. +Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. +Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. +Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. + +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; +}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + + +(*** Arrays *) +Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. + +Lemma le_0_usize_max : 0 <= usize_max. +Proof. + pose (H := usize_max_bound). + unfold u32_max in H. + lia. +Qed. + +Lemma eqb_imp_eq (x y : Z) : Z.eqb x y = true -> x = y. +Proof. + lia. +Qed. + +(* TODO: finish the definitions *) +Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. + +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). + +(*** Slice *) +Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. + +Axiom slice_len : forall (T : Type) (s : slice T), usize. +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). + +(*** Subslices *) + +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). + +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). + +(*** Vectors *) + +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. + +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. + +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). + +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). + +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. +Proof. + unfold alloc_vec_Vec_length, usize_min. + split. + - lia. + - apply (proj2_sig v). +Qed. + +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). + +Fixpoint list_update {A} (l: list A) (n: nat) (a: A) + : list A := + match l with + | [] => [] + | x :: t => match n with + | 0%nat => a :: t + | S m => x :: (list_update t m a) +end end. + +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; + match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with + | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) + | right _ => Fail_ Failure + end. + +(* The **forward** function shouldn't be used *) +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. + +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). + +(* The **forward** function shouldn't be used *) +Definition alloc_vec_Vec_insert_fwd (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result unit := + if to_Z i <? alloc_vec_Vec_length v then Return tt else Fail_ Failure. + +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => + if to_Z i <? Z.of_nat (length l) + then Return (list_update l (usize_to_nat i) x) + else Fail_ Failure). + +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x + end. + +(* [core::slice::index::Range:::get]: forward function *) +Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: forward function *) +Axiom core_slice_index_Range_get_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. + +End Primitives. diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v new file mode 100644 index 00000000..e104fb66 --- /dev/null +++ b/tests/coq/traits/Traits.v @@ -0,0 +1,520 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [traits] *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module Traits. + +(** Trait declaration: [traits::BoolTrait] *) +Record BoolTrait_t (Self : Type) := mkBoolTrait_t { + BoolTrait_t_get_bool : Self -> result bool; +}. + +Arguments mkBoolTrait_t { _ }. +Arguments BoolTrait_t_get_bool { _ }. + +(** [traits::Bool::{0}::get_bool]: forward function *) +Definition bool_get_bool (self : bool) : result bool := + Return self. + +(** Trait implementation: [traits::Bool::{0}] *) +Definition Bool_BoolTraitInst : BoolTrait_t bool := {| + BoolTrait_t_get_bool := bool_get_bool; +|}. + +(** [traits::BoolTrait::ret_true]: forward function *) +Definition boolTrait_ret_true + {Self : Type} (self_clause : BoolTrait_t Self) (self : Self) : result bool := + Return true +. + +(** [traits::test_bool_trait_bool]: forward function *) +Definition test_bool_trait_bool (x : bool) : result bool := + b <- bool_get_bool x; + if b then boolTrait_ret_true Bool_BoolTraitInst x else Return false +. + +(** [traits::Option::{1}::get_bool]: forward function *) +Definition option_get_bool (T : Type) (self : option T) : result bool := + match self with | None => Return false | Some t => Return true end +. + +(** Trait implementation: [traits::Option::{1}] *) +Definition Option_BoolTraitInst (T : Type) : BoolTrait_t (option T) := {| + BoolTrait_t_get_bool := option_get_bool T; +|}. + +(** [traits::test_bool_trait_option]: forward function *) +Definition test_bool_trait_option (T : Type) (x : option T) : result bool := + b <- option_get_bool T x; + if b then boolTrait_ret_true (Option_BoolTraitInst T) x else Return false +. + +(** [traits::test_bool_trait]: forward function *) +Definition test_bool_trait + (T : Type) (inst : BoolTrait_t T) (x : T) : result bool := + inst.(BoolTrait_t_get_bool) x +. + +(** Trait declaration: [traits::ToU64] *) +Record ToU64_t (Self : Type) := mkToU64_t { + ToU64_t_to_u64 : Self -> result u64; +}. + +Arguments mkToU64_t { _ }. +Arguments ToU64_t_to_u64 { _ }. + +(** [traits::u64::{2}::to_u64]: forward function *) +Definition u64_to_u64 (self : u64) : result u64 := + Return self. + +(** Trait implementation: [traits::u64::{2}] *) +Definition u64_ToU64Inst : ToU64_t u64 := {| ToU64_t_to_u64 := u64_to_u64; |}. + +(** [traits::Tuple2::{3}::to_u64]: forward function *) +Definition tuple2_to_u64 + (A : Type) (inst : ToU64_t A) (self : (A * A)) : result u64 := + let (t, t0) := self in + i <- inst.(ToU64_t_to_u64) t; + i0 <- inst.(ToU64_t_to_u64) t0; + u64_add i i0 +. + +(** Trait implementation: [traits::Tuple2::{3}] *) +Definition Tuple2_ToU64Inst (A : Type) (inst : ToU64_t A) : ToU64_t (A * A) + := {| + ToU64_t_to_u64 := tuple2_to_u64 A inst; +|}. + +(** [traits::f]: forward function *) +Definition f (T : Type) (inst : ToU64_t T) (x : (T * T)) : result u64 := + tuple2_to_u64 T inst x +. + +(** [traits::g]: forward function *) +Definition g (T : Type) (inst : ToU64_t (T * T)) (x : (T * T)) : result u64 := + inst.(ToU64_t_to_u64) x +. + +(** [traits::h0]: forward function *) +Definition h0 (x : u64) : result u64 := + u64_to_u64 x. + +(** [traits::Wrapper] *) +Record Wrapper_t (T : Type) := mkWrapper_t { wrapper_x : T; }. + +Arguments mkWrapper_t { _ }. +Arguments wrapper_x { _ }. + +(** [traits::Wrapper::{4}::to_u64]: forward function *) +Definition wrapper_to_u64 + (T : Type) (inst : ToU64_t T) (self : Wrapper_t T) : result u64 := + inst.(ToU64_t_to_u64) self.(wrapper_x) +. + +(** Trait implementation: [traits::Wrapper::{4}] *) +Definition Wrapper_ToU64Inst (T : Type) (inst : ToU64_t T) : ToU64_t (Wrapper_t + T) := {| + ToU64_t_to_u64 := wrapper_to_u64 T inst; +|}. + +(** [traits::h1]: forward function *) +Definition h1 (x : Wrapper_t u64) : result u64 := + wrapper_to_u64 u64 u64_ToU64Inst x +. + +(** [traits::h2]: forward function *) +Definition h2 (T : Type) (inst : ToU64_t T) (x : Wrapper_t T) : result u64 := + wrapper_to_u64 T inst x +. + +(** Trait declaration: [traits::ToType] *) +Record ToType_t (Self T : Type) := mkToType_t { + ToType_t_to_type : Self -> result T; +}. + +Arguments mkToType_t { _ _ }. +Arguments ToType_t_to_type { _ _ }. + +(** [traits::u64::{5}::to_type]: forward function *) +Definition u64_to_type (self : u64) : result bool := + Return (self s> 0%u64). + +(** Trait implementation: [traits::u64::{5}] *) +Definition u64_ToTypeInst : ToType_t u64 bool := {| + ToType_t_to_type := u64_to_type; +|}. + +(** Trait declaration: [traits::OfType] *) +Record OfType_t (Self : Type) := mkOfType_t { + OfType_t_of_type : forall (T : Type) (inst : ToType_t T Self), T -> result + Self; +}. + +Arguments mkOfType_t { _ }. +Arguments OfType_t_of_type { _ }. + +(** [traits::h3]: forward function *) +Definition h3 + (T1 T2 : Type) (inst : OfType_t T1) (inst0 : ToType_t T2 T1) (y : T2) : + result T1 + := + inst.(OfType_t_of_type) T2 inst0 y +. + +(** Trait declaration: [traits::OfTypeBis] *) +Record OfTypeBis_t (Self T : Type) := mkOfTypeBis_t { + OfTypeBis_tOfTypeBis_t_parent_clause_0 : ToType_t T Self; + OfTypeBis_t_of_type : T -> result Self; +}. + +Arguments mkOfTypeBis_t { _ _ }. +Arguments OfTypeBis_tOfTypeBis_t_parent_clause_0 { _ _ }. +Arguments OfTypeBis_t_of_type { _ _ }. + +(** [traits::h4]: forward function *) +Definition h4 + (T1 T2 : Type) (inst : OfTypeBis_t T1 T2) (inst0 : ToType_t T2 T1) (y : T2) : + result T1 + := + inst.(OfTypeBis_t_of_type) y +. + +(** [traits::TestType] *) +Record TestType_t (T : Type) := mkTestType_t { testType_0 : T; }. + +Arguments mkTestType_t { _ }. +Arguments testType_0 { _ }. + +(** [traits::TestType::{6}::test::TestType1] *) +Record TestType_test_TestType1_t := +mkTestType_test_TestType1_t { + testType_test_TestType1_0 : u64; +} +. + +(** Trait declaration: [traits::TestType::{6}::test::TestTrait] *) +Record TestType_test_TestTrait_t (Self : Type) := mkTestType_test_TestTrait_t { + TestType_test_TestTrait_t_test : Self -> result bool; +}. + +Arguments mkTestType_test_TestTrait_t { _ }. +Arguments TestType_test_TestTrait_t_test { _ }. + +(** [traits::TestType::{6}::test::TestType1::{0}::test]: forward function *) +Definition testType_test_TestType1_test + (self : TestType_test_TestType1_t) : result bool := + Return (self.(testType_test_TestType1_0) s> 1%u64) +. + +(** Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] *) +Definition TestType_test_TestType1_TestType_test_TestTraitInst : + TestType_test_TestTrait_t TestType_test_TestType1_t := {| + TestType_test_TestTrait_t_test := testType_test_TestType1_test; +|}. + +(** [traits::TestType::{6}::test]: forward function *) +Definition testType_test + (T : Type) (inst : ToU64_t T) (self : TestType_t T) (x : T) : result bool := + x0 <- inst.(ToU64_t_to_u64) x; + if x0 s> 0%u64 + then testType_test_TestType1_test {| testType_test_TestType1_0 := 0%u64 |} + else Return false +. + +(** [traits::BoolWrapper] *) +Record BoolWrapper_t := mkBoolWrapper_t { boolWrapper_0 : bool; }. + +(** [traits::BoolWrapper::{7}::to_type]: forward function *) +Definition boolWrapper_to_type + (T : Type) (inst : ToType_t bool T) (self : BoolWrapper_t) : result T := + inst.(ToType_t_to_type) self.(boolWrapper_0) +. + +(** Trait implementation: [traits::BoolWrapper::{7}] *) +Definition BoolWrapper_ToTypeInst (T : Type) (inst : ToType_t bool T) : + ToType_t BoolWrapper_t T := {| + ToType_t_to_type := boolWrapper_to_type T inst; +|}. + +(** [traits::WithConstTy::LEN2] *) +Definition with_const_ty_len2_body : result usize := Return 32%usize. +Definition with_const_ty_len2_c : usize := with_const_ty_len2_body%global. + +(** Trait declaration: [traits::WithConstTy] *) +Record WithConstTy_t (Self : Type) (LEN : usize) := mkWithConstTy_t { + WithConstTy_tWithConstTy_t_LEN1 : usize; + WithConstTy_tWithConstTy_t_LEN2 : usize; + WithConstTy_tWithConstTy_t_V : Type; + WithConstTy_tWithConstTy_t_W : Type; + WithConstTy_tWithConstTy_t_W_clause_0 : ToU64_t WithConstTy_tWithConstTy_t_W; + WithConstTy_t_f : WithConstTy_tWithConstTy_t_W -> array u8 LEN -> result + WithConstTy_tWithConstTy_t_W; +}. + +Arguments mkWithConstTy_t { _ _ }. +Arguments WithConstTy_tWithConstTy_t_LEN1 { _ _ }. +Arguments WithConstTy_tWithConstTy_t_LEN2 { _ _ }. +Arguments WithConstTy_tWithConstTy_t_V { _ _ }. +Arguments WithConstTy_tWithConstTy_t_W { _ _ }. +Arguments WithConstTy_tWithConstTy_t_W_clause_0 { _ _ }. +Arguments WithConstTy_t_f { _ _ }. + +(** [traits::Bool::{8}::LEN1] *) +Definition bool_len1_body : result usize := Return 12%usize. +Definition bool_len1_c : usize := bool_len1_body%global. + +(** [traits::Bool::{8}::f]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition bool_f (i : u64) (a : array u8 32%usize) : result u64 := + Return i. + +(** Trait implementation: [traits::Bool::{8}] *) +Definition Bool_WithConstTyInst : WithConstTy_t bool 32%usize := {| + WithConstTy_tWithConstTy_t_LEN1 := bool_len1_c; + WithConstTy_tWithConstTy_t_LEN2 := with_const_ty_len2_c; + WithConstTy_tWithConstTy_t_V := u8; + WithConstTy_tWithConstTy_t_W := u64; + WithConstTy_tWithConstTy_t_W_clause_0 := u64_ToU64Inst; + WithConstTy_t_f := bool_f; +|}. + +(** [traits::use_with_const_ty1]: forward function *) +Definition use_with_const_ty1 + (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) : result usize := + let i := inst.(WithConstTy_tWithConstTy_t_LEN1) in Return i +. + +(** [traits::use_with_const_ty2]: forward function *) +Definition use_with_const_ty2 + (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) + (w : inst.(WithConstTy_tWithConstTy_t_W)) : + result unit + := + Return tt +. + +(** [traits::use_with_const_ty3]: forward function *) +Definition use_with_const_ty3 + (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) + (x : inst.(WithConstTy_tWithConstTy_t_W)) : + result u64 + := + inst.(WithConstTy_tWithConstTy_t_W_clause_0).(ToU64_t_to_u64) x +. + +(** [traits::test_where1]: forward function *) +Definition test_where1 (T : Type) (_x : T) : result unit := + Return tt. + +(** [traits::test_where2]: forward function *) +Definition test_where2 + (T : Type) (inst : WithConstTy_t T 32%usize) (_x : u32) : result unit := + Return tt +. + +(** [alloc::string::String] *) +Axiom alloc_string_String_t : Type. + +(** Trait declaration: [traits::ParentTrait0] *) +Record ParentTrait0_t (Self : Type) := mkParentTrait0_t { + ParentTrait0_tParentTrait0_t_W : Type; + ParentTrait0_t_get_name : Self -> result alloc_string_String_t; + ParentTrait0_t_get_w : Self -> result ParentTrait0_tParentTrait0_t_W; +}. + +Arguments mkParentTrait0_t { _ }. +Arguments ParentTrait0_tParentTrait0_t_W { _ }. +Arguments ParentTrait0_t_get_name { _ }. +Arguments ParentTrait0_t_get_w { _ }. + +(** Trait declaration: [traits::ParentTrait1] *) +Record ParentTrait1_t (Self : Type) := mkParentTrait1_t{}. + +Arguments mkParentTrait1_t { _ }. + +(** Trait declaration: [traits::ChildTrait] *) +Record ChildTrait_t (Self : Type) := mkChildTrait_t { + ChildTrait_tChildTrait_t_parent_clause_0 : ParentTrait0_t Self; + ChildTrait_tChildTrait_t_parent_clause_1 : ParentTrait1_t Self; +}. + +Arguments mkChildTrait_t { _ }. +Arguments ChildTrait_tChildTrait_t_parent_clause_0 { _ }. +Arguments ChildTrait_tChildTrait_t_parent_clause_1 { _ }. + +(** [traits::test_child_trait1]: forward function *) +Definition test_child_trait1 + (T : Type) (inst : ChildTrait_t T) (x : T) : result alloc_string_String_t := + inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_t_get_name) x +. + +(** [traits::test_child_trait2]: forward function *) +Definition test_child_trait2 + (T : Type) (inst : ChildTrait_t T) (x : T) : + result + inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_tParentTrait0_t_W) + := + inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_t_get_w) x +. + +(** [traits::order1]: forward function *) +Definition order1 + (T U : Type) (inst : ParentTrait0_t T) (inst0 : ParentTrait0_t U) : + result unit + := + Return tt +. + +(** Trait declaration: [traits::ChildTrait1] *) +Record ChildTrait1_t (Self : Type) := mkChildTrait1_t { + ChildTrait1_tChildTrait1_t_parent_clause_0 : ParentTrait1_t Self; +}. + +Arguments mkChildTrait1_t { _ }. +Arguments ChildTrait1_tChildTrait1_t_parent_clause_0 { _ }. + +(** Trait implementation: [traits::usize::{9}] *) +Definition usize_ParentTrait1Inst : ParentTrait1_t usize := mkParentTrait1_t. + +(** Trait implementation: [traits::usize::{10}] *) +Definition usize_ChildTrait1Inst : ChildTrait1_t usize := {| + ChildTrait1_tChildTrait1_t_parent_clause_0 := usize_ParentTrait1Inst; +|}. + +(** Trait declaration: [traits::Iterator] *) +Record Iterator_t (Self : Type) := mkIterator_t { + Iterator_tIterator_t_Item : Type; +}. + +Arguments mkIterator_t { _ }. +Arguments Iterator_tIterator_t_Item { _ }. + +(** Trait declaration: [traits::IntoIterator] *) +Record IntoIterator_t (Self : Type) := mkIntoIterator_t { + IntoIterator_tIntoIterator_t_Item : Type; + IntoIterator_tIntoIterator_t_IntoIter : Type; + IntoIterator_tIntoIterator_t_IntoIter_clause_0 : Iterator_t + IntoIterator_tIntoIterator_t_IntoIter; + IntoIterator_t_into_iter : Self -> result + IntoIterator_tIntoIterator_t_IntoIter; +}. + +Arguments mkIntoIterator_t { _ }. +Arguments IntoIterator_tIntoIterator_t_Item { _ }. +Arguments IntoIterator_tIntoIterator_t_IntoIter { _ }. +Arguments IntoIterator_tIntoIterator_t_IntoIter_clause_0 { _ }. +Arguments IntoIterator_t_into_iter { _ }. + +(** Trait declaration: [traits::FromResidual] *) +Record FromResidual_t (Self T : Type) := mkFromResidual_t{}. + +Arguments mkFromResidual_t { _ _ }. + +(** Trait declaration: [traits::Try] *) +Record Try_t (Self : Type) := mkTry_t { + Try_tTry_t_Residual : Type; + Try_tTry_t_parent_clause_0 : FromResidual_t Self Try_tTry_t_Residual; +}. + +Arguments mkTry_t { _ }. +Arguments Try_tTry_t_Residual { _ }. +Arguments Try_tTry_t_parent_clause_0 { _ }. + +(** Trait declaration: [traits::WithTarget] *) +Record WithTarget_t (Self : Type) := mkWithTarget_t { + WithTarget_tWithTarget_t_Target : Type; +}. + +Arguments mkWithTarget_t { _ }. +Arguments WithTarget_tWithTarget_t_Target { _ }. + +(** Trait declaration: [traits::ParentTrait2] *) +Record ParentTrait2_t (Self : Type) := mkParentTrait2_t { + ParentTrait2_tParentTrait2_t_U : Type; + ParentTrait2_tParentTrait2_t_U_clause_0 : WithTarget_t + ParentTrait2_tParentTrait2_t_U; +}. + +Arguments mkParentTrait2_t { _ }. +Arguments ParentTrait2_tParentTrait2_t_U { _ }. +Arguments ParentTrait2_tParentTrait2_t_U_clause_0 { _ }. + +(** Trait declaration: [traits::ChildTrait2] *) +Record ChildTrait2_t (Self : Type) := mkChildTrait2_t { + ChildTrait2_tChildTrait2_t_parent_clause_0 : ParentTrait2_t Self; + ChildTrait2_t_convert : + (ChildTrait2_tChildTrait2_t_parent_clause_0).(ParentTrait2_tParentTrait2_t_U) + -> result + (ChildTrait2_tChildTrait2_t_parent_clause_0).(ParentTrait2_tParentTrait2_t_U_clause_0).(WithTarget_tWithTarget_t_Target); +}. + +Arguments mkChildTrait2_t { _ }. +Arguments ChildTrait2_tChildTrait2_t_parent_clause_0 { _ }. +Arguments ChildTrait2_t_convert { _ }. + +(** Trait implementation: [traits::u32::{11}] *) +Definition u32_WithTargetInst : WithTarget_t u32 := {| + WithTarget_tWithTarget_t_Target := u32; +|}. + +(** Trait implementation: [traits::u32::{12}] *) +Definition u32_ParentTrait2Inst : ParentTrait2_t u32 := {| + ParentTrait2_tParentTrait2_t_U := u32; + ParentTrait2_tParentTrait2_t_U_clause_0 := u32_WithTargetInst; +|}. + +(** [traits::u32::{13}::convert]: forward function *) +Definition u32_convert (x : u32) : result u32 := + Return x. + +(** Trait implementation: [traits::u32::{13}] *) +Definition u32_ChildTrait2Inst : ChildTrait2_t u32 := {| + ChildTrait2_tChildTrait2_t_parent_clause_0 := u32_ParentTrait2Inst; + ChildTrait2_t_convert := u32_convert; +|}. + +(** [traits::incr_u32]: forward function *) +Definition incr_u32 (x : u32) : result u32 := + u32_add x 1%u32. + +(** Trait declaration: [traits::CFnOnce] *) +Record CFnOnce_t (Self Args : Type) := mkCFnOnce_t { + CFnOnce_tCFnOnce_t_Output : Type; + CFnOnce_t_call_once : Self -> Args -> result CFnOnce_tCFnOnce_t_Output; +}. + +Arguments mkCFnOnce_t { _ _ }. +Arguments CFnOnce_tCFnOnce_t_Output { _ _ }. +Arguments CFnOnce_t_call_once { _ _ }. + +(** Trait declaration: [traits::CFnMut] *) +Record CFnMut_t (Self Args : Type) := mkCFnMut_t { + CFnMut_tCFnMut_t_parent_clause_0 : CFnOnce_t Self Args; + CFnMut_t_call_mut : Self -> Args -> result + (CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output); + CFnMut_t_call_mut_back : Self -> Args -> + (CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output) -> result + Self; +}. + +Arguments mkCFnMut_t { _ _ }. +Arguments CFnMut_tCFnMut_t_parent_clause_0 { _ _ }. +Arguments CFnMut_t_call_mut { _ _ }. +Arguments CFnMut_t_call_mut_back { _ _ }. + +(** Trait declaration: [traits::CFn] *) +Record CFn_t (Self Args : Type) := mkCFn_t { + CFn_tCFn_t_parent_clause_0 : CFnMut_t Self Args; + CFn_t_call_mut : Self -> Args -> result + (CFn_tCFn_t_parent_clause_0).(CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output); +}. + +Arguments mkCFn_t { _ _ }. +Arguments CFn_tCFn_t_parent_clause_0 { _ _ }. +Arguments CFn_t_call_mut { _ _ }. + +End Traits . diff --git a/tests/coq/traits/_CoqProject b/tests/coq/traits/_CoqProject new file mode 100644 index 00000000..5b6199fc --- /dev/null +++ b/tests/coq/traits/_CoqProject @@ -0,0 +1,7 @@ +# This file was automatically generated - see ../Makefile +-R . Lib +-arg -w +-arg all + +Traits.v +Primitives.v diff --git a/tests/fstar/array/Array.Clauses.Template.fst b/tests/fstar/array/Array.Clauses.Template.fst index 8a15e230..06056d61 100644 --- a/tests/fstar/array/Array.Clauses.Template.fst +++ b/tests/fstar/array/Array.Clauses.Template.fst @@ -8,11 +8,12 @@ open Array.Types (** [array::sum]: decreases clause *) unfold -let sum_loop_decreases (s : slice u32) (sum : u32) (i : usize) : nat = admit () +let sum_loop_decreases (s : slice u32) (sum0 : u32) (i : usize) : nat = + admit () (** [array::sum2]: decreases clause *) unfold -let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum : u32) +let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : nat = admit () diff --git a/tests/fstar/array/Array.Funs.fst b/tests/fstar/array/Array.Funs.fst index 7c1d0b09..8f0bfbbd 100644 --- a/tests/fstar/array/Array.Funs.fst +++ b/tests/fstar/array/Array.Funs.fst @@ -7,349 +7,369 @@ include Array.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" +(** [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let incr (x : u32) : result u32 = + u32_add x 1 + (** [array::array_to_shared_slice_]: forward function *) -let array_to_shared_slice__fwd - (t : Type0) (s : array t 32) : result (slice t) = - array_to_slice_shared t 32 s +let array_to_shared_slice_ (t : Type0) (s : array t 32) : result (slice t) = + array_to_slice t 32 s (** [array::array_to_mut_slice_]: forward function *) -let array_to_mut_slice__fwd (t : Type0) (s : array t 32) : result (slice t) = - array_to_slice_mut_fwd t 32 s +let array_to_mut_slice_ (t : Type0) (s : array t 32) : result (slice t) = + array_to_slice t 32 s (** [array::array_to_mut_slice_]: backward function 0 *) let array_to_mut_slice__back (t : Type0) (s : array t 32) (ret : slice t) : result (array t 32) = - array_to_slice_mut_back t 32 s ret + array_from_slice t 32 s ret (** [array::array_len]: forward function *) -let array_len_fwd (t : Type0) (s : array t 32) : result usize = - let* s0 = array_to_slice_shared t 32 s in let i = slice_len t s0 in Return i +let array_len (t : Type0) (s : array t 32) : result usize = + let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i (** [array::shared_array_len]: forward function *) -let shared_array_len_fwd (t : Type0) (s : array t 32) : result usize = - let* s0 = array_to_slice_shared t 32 s in let i = slice_len t s0 in Return i +let shared_array_len (t : Type0) (s : array t 32) : result usize = + let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i (** [array::shared_slice_len]: forward function *) -let shared_slice_len_fwd (t : Type0) (s : slice t) : result usize = +let shared_slice_len (t : Type0) (s : slice t) : result usize = let i = slice_len t s in Return i (** [array::index_array_shared]: forward function *) -let index_array_shared_fwd - (t : Type0) (s : array t 32) (i : usize) : result t = - array_index_shared t 32 s i +let index_array_shared (t : Type0) (s : array t 32) (i : usize) : result t = + array_index_usize t 32 s i (** [array::index_array_u32]: forward function *) -let index_array_u32_fwd (s : array u32 32) (i : usize) : result u32 = - array_index_shared u32 32 s i - -(** [array::index_array_generic]: forward function *) -let index_array_generic_fwd - (n : usize) (s : array u32 n) (i : usize) : result u32 = - array_index_shared u32 n s i - -(** [array::index_array_generic_call]: forward function *) -let index_array_generic_call_fwd - (n : usize) (s : array u32 n) (i : usize) : result u32 = - index_array_generic_fwd n s i +let index_array_u32 (s : array u32 32) (i : usize) : result u32 = + array_index_usize u32 32 s i (** [array::index_array_copy]: forward function *) -let index_array_copy_fwd (x : array u32 32) : result u32 = - array_index_shared u32 32 x 0 +let index_array_copy (x : array u32 32) : result u32 = + array_index_usize u32 32 x 0 (** [array::index_mut_array]: forward function *) -let index_mut_array_fwd (t : Type0) (s : array t 32) (i : usize) : result t = - array_index_mut_fwd t 32 s i +let index_mut_array (t : Type0) (s : array t 32) (i : usize) : result t = + array_index_usize t 32 s i (** [array::index_mut_array]: backward function 0 *) let index_mut_array_back (t : Type0) (s : array t 32) (i : usize) (ret : t) : result (array t 32) = - array_index_mut_back t 32 s i ret + array_update_usize t 32 s i ret (** [array::index_slice]: forward function *) -let index_slice_fwd (t : Type0) (s : slice t) (i : usize) : result t = - slice_index_shared t s i +let index_slice (t : Type0) (s : slice t) (i : usize) : result t = + slice_index_usize t s i (** [array::index_mut_slice]: forward function *) -let index_mut_slice_fwd (t : Type0) (s : slice t) (i : usize) : result t = - slice_index_mut_fwd t s i +let index_mut_slice (t : Type0) (s : slice t) (i : usize) : result t = + slice_index_usize t s i (** [array::index_mut_slice]: backward function 0 *) let index_mut_slice_back (t : Type0) (s : slice t) (i : usize) (ret : t) : result (slice t) = - slice_index_mut_back t s i ret + slice_update_usize t s i ret (** [array::slice_subslice_shared_]: forward function *) -let slice_subslice_shared__fwd +let slice_subslice_shared_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) = - slice_subslice_shared u32 x (Mkrange y z) + core_slice_index_Slice_index u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } (** [array::slice_subslice_mut_]: forward function *) -let slice_subslice_mut__fwd +let slice_subslice_mut_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) = - slice_subslice_mut_fwd u32 x (Mkrange y z) + core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } (** [array::slice_subslice_mut_]: backward function 0 *) let slice_subslice_mut__back (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : result (slice u32) = - slice_subslice_mut_back u32 x (Mkrange y z) ret + core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } ret (** [array::array_to_slice_shared_]: forward function *) -let array_to_slice_shared__fwd (x : array u32 32) : result (slice u32) = - array_to_slice_shared u32 32 x +let array_to_slice_shared_ (x : array u32 32) : result (slice u32) = + array_to_slice u32 32 x (** [array::array_to_slice_mut_]: forward function *) -let array_to_slice_mut__fwd (x : array u32 32) : result (slice u32) = - array_to_slice_mut_fwd u32 32 x +let array_to_slice_mut_ (x : array u32 32) : result (slice u32) = + array_to_slice u32 32 x (** [array::array_to_slice_mut_]: backward function 0 *) let array_to_slice_mut__back (x : array u32 32) (ret : slice u32) : result (array u32 32) = - array_to_slice_mut_back u32 32 x ret + array_from_slice u32 32 x ret (** [array::array_subslice_shared_]: forward function *) -let array_subslice_shared__fwd +let array_subslice_shared_ (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - array_subslice_shared u32 32 x (Mkrange y z) + core_array_Array_index u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } (** [array::array_subslice_mut_]: forward function *) -let array_subslice_mut__fwd +let array_subslice_mut_ (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - array_subslice_mut_fwd u32 32 x (Mkrange y z) + core_array_Array_index_mut u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } (** [array::array_subslice_mut_]: backward function 0 *) let array_subslice_mut__back (x : array u32 32) (y : usize) (z : usize) (ret : slice u32) : result (array u32 32) = - array_subslice_mut_back u32 32 x (Mkrange y z) ret + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } ret (** [array::index_slice_0]: forward function *) -let index_slice_0_fwd (t : Type0) (s : slice t) : result t = - slice_index_shared t s 0 +let index_slice_0 (t : Type0) (s : slice t) : result t = + slice_index_usize t s 0 (** [array::index_array_0]: forward function *) -let index_array_0_fwd (t : Type0) (s : array t 32) : result t = - array_index_shared t 32 s 0 +let index_array_0 (t : Type0) (s : array t 32) : result t = + array_index_usize t 32 s 0 (** [array::index_index_array]: forward function *) -let index_index_array_fwd +let index_index_array (s : array (array u32 32) 32) (i : usize) (j : usize) : result u32 = - let* a = array_index_shared (array u32 32) 32 s i in - array_index_shared u32 32 a j + let* a = array_index_usize (array u32 32) 32 s i in + array_index_usize u32 32 a j (** [array::update_update_array]: forward function *) -let update_update_array_fwd +let update_update_array (s : array (array u32 32) 32) (i : usize) (j : usize) : result unit = - let* a = array_index_mut_fwd (array u32 32) 32 s i in - let* a0 = array_index_mut_back u32 32 a j 0 in - let* _ = array_index_mut_back (array u32 32) 32 s i a0 in + let* a = array_index_usize (array u32 32) 32 s i in + let* a0 = array_update_usize u32 32 a j 0 in + let* _ = array_update_usize (array u32 32) 32 s i a0 in Return () (** [array::array_local_deep_copy]: forward function *) -let array_local_deep_copy_fwd (x : array u32 32) : result unit = +let array_local_deep_copy (x : array u32 32) : result unit = Return () (** [array::take_array]: forward function *) -let take_array_fwd (a : array u32 2) : result unit = +let take_array (a : array u32 2) : result unit = Return () (** [array::take_array_borrow]: forward function *) -let take_array_borrow_fwd (a : array u32 2) : result unit = +let take_array_borrow (a : array u32 2) : result unit = Return () (** [array::take_slice]: forward function *) -let take_slice_fwd (s : slice u32) : result unit = +let take_slice (s : slice u32) : result unit = Return () (** [array::take_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let take_mut_slice_fwd_back (s : slice u32) : result (slice u32) = +let take_mut_slice (s : slice u32) : result (slice u32) = Return s (** [array::take_all]: forward function *) -let take_all_fwd : result unit = - let* _ = take_array_fwd (mk_array u32 2 [ 0; 0 ]) in - let* _ = take_array_borrow_fwd (mk_array u32 2 [ 0; 0 ]) in - let* s = array_to_slice_shared u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* _ = take_slice_fwd s in - let* s0 = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* s1 = take_mut_slice_fwd_back s0 in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in +let take_all : result unit = + let* _ = take_array (mk_array u32 2 [ 0; 0 ]) in + let* _ = take_array_borrow (mk_array u32 2 [ 0; 0 ]) in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* _ = take_slice s in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* s1 = take_mut_slice s0 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in Return () (** [array::index_array]: forward function *) -let index_array_fwd (x : array u32 2) : result u32 = - array_index_shared u32 2 x 0 +let index_array (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 (** [array::index_array_borrow]: forward function *) -let index_array_borrow_fwd (x : array u32 2) : result u32 = - array_index_shared u32 2 x 0 +let index_array_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 (** [array::index_slice_u32_0]: forward function *) -let index_slice_u32_0_fwd (x : slice u32) : result u32 = - slice_index_shared u32 x 0 +let index_slice_u32_0 (x : slice u32) : result u32 = + slice_index_usize u32 x 0 (** [array::index_mut_slice_u32_0]: forward function *) -let index_mut_slice_u32_0_fwd (x : slice u32) : result u32 = - slice_index_shared u32 x 0 +let index_mut_slice_u32_0 (x : slice u32) : result u32 = + slice_index_usize u32 x 0 (** [array::index_mut_slice_u32_0]: backward function 0 *) let index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) = - let* _ = slice_index_shared u32 x 0 in Return x + let* _ = slice_index_usize u32 x 0 in Return x (** [array::index_all]: forward function *) -let index_all_fwd : result u32 = - let* i = index_array_fwd (mk_array u32 2 [ 0; 0 ]) in - let* i0 = index_array_fwd (mk_array u32 2 [ 0; 0 ]) in +let index_all : result u32 = + let* i = index_array (mk_array u32 2 [ 0; 0 ]) in + let* i0 = index_array (mk_array u32 2 [ 0; 0 ]) in let* i1 = u32_add i i0 in - let* i2 = index_array_borrow_fwd (mk_array u32 2 [ 0; 0 ]) in + let* i2 = index_array_borrow (mk_array u32 2 [ 0; 0 ]) in let* i3 = u32_add i1 i2 in - let* s = array_to_slice_shared u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* i4 = index_slice_u32_0_fwd s in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* i4 = index_slice_u32_0 s in let* i5 = u32_add i3 i4 in - let* s0 = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* i6 = index_mut_slice_u32_0_fwd s0 in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* i6 = index_mut_slice_u32_0 s0 in let* i7 = u32_add i5 i6 in let* s1 = index_mut_slice_u32_0_back s0 in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in Return i7 (** [array::update_array]: forward function *) -let update_array_fwd (x : array u32 2) : result unit = - let* _ = array_index_mut_back u32 2 x 0 1 in Return () +let update_array (x : array u32 2) : result unit = + let* _ = array_update_usize u32 2 x 0 1 in Return () (** [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let update_array_mut_borrow_fwd_back (x : array u32 2) : result (array u32 2) = - array_index_mut_back u32 2 x 0 1 +let update_array_mut_borrow (x : array u32 2) : result (array u32 2) = + array_update_usize u32 2 x 0 1 (** [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let update_mut_slice_fwd_back (x : slice u32) : result (slice u32) = - slice_index_mut_back u32 x 0 1 +let update_mut_slice (x : slice u32) : result (slice u32) = + slice_update_usize u32 x 0 1 (** [array::update_all]: forward function *) -let update_all_fwd : result unit = - let* _ = update_array_fwd (mk_array u32 2 [ 0; 0 ]) in - let* x = update_array_mut_borrow_fwd_back (mk_array u32 2 [ 0; 0 ]) in - let* s = array_to_slice_mut_fwd u32 2 x in - let* s0 = update_mut_slice_fwd_back s in - let* _ = array_to_slice_mut_back u32 2 x s0 in +let update_all : result unit = + let* _ = update_array (mk_array u32 2 [ 0; 0 ]) in + let* x = update_array_mut_borrow (mk_array u32 2 [ 0; 0 ]) in + let* s = array_to_slice u32 2 x in + let* s0 = update_mut_slice s in + let* _ = array_from_slice u32 2 x s0 in Return () (** [array::range_all]: forward function *) -let range_all_fwd : result unit = +let range_all : result unit = let* s = - array_subslice_mut_fwd u32 4 (mk_array u32 4 [ 0; 0; 0; 0 ]) (Mkrange 1 3) - in - let* s0 = update_mut_slice_fwd_back s in + core_array_Array_index_mut u32 (core_ops_range_Range usize) 4 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } in + let* s0 = update_mut_slice s in let* _ = - array_subslice_mut_back u32 4 (mk_array u32 4 [ 0; 0; 0; 0 ]) (Mkrange 1 3) - s0 in + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } s0 in Return () (** [array::deref_array_borrow]: forward function *) -let deref_array_borrow_fwd (x : array u32 2) : result u32 = - array_index_shared u32 2 x 0 +let deref_array_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 (** [array::deref_array_mut_borrow]: forward function *) -let deref_array_mut_borrow_fwd (x : array u32 2) : result u32 = - array_index_shared u32 2 x 0 +let deref_array_mut_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 (** [array::deref_array_mut_borrow]: backward function 0 *) let deref_array_mut_borrow_back (x : array u32 2) : result (array u32 2) = - let* _ = array_index_shared u32 2 x 0 in Return x + let* _ = array_index_usize u32 2 x 0 in Return x (** [array::take_array_t]: forward function *) -let take_array_t_fwd (a : array t_t 2) : result unit = +let take_array_t (a : array aB_t 2) : result unit = Return () (** [array::non_copyable_array]: forward function *) -let non_copyable_array_fwd : result unit = - let* _ = take_array_t_fwd (mk_array t_t 2 [ TA; TB ]) in Return () +let non_copyable_array : result unit = + let* _ = take_array_t (mk_array aB_t 2 [ AB_A; AB_B ]) in Return () (** [array::sum]: loop 0: forward function *) -let rec sum_loop_fwd - (s : slice u32) (sum : u32) (i : usize) : - Tot (result u32) (decreases (sum_loop_decreases s sum i)) +let rec sum_loop + (s : slice u32) (sum0 : u32) (i : usize) : + Tot (result u32) (decreases (sum_loop_decreases s sum0 i)) = let i0 = slice_len u32 s in if i < i0 then - let* i1 = slice_index_shared u32 s i in - let* sum0 = u32_add sum i1 in + let* i1 = slice_index_usize u32 s i in + let* sum1 = u32_add sum0 i1 in let* i2 = usize_add i 1 in - sum_loop_fwd s sum0 i2 - else Return sum + sum_loop s sum1 i2 + else Return sum0 (** [array::sum]: forward function *) -let sum_fwd (s : slice u32) : result u32 = - sum_loop_fwd s 0 0 +let sum (s : slice u32) : result u32 = + sum_loop s 0 0 (** [array::sum2]: loop 0: forward function *) -let rec sum2_loop_fwd - (s : slice u32) (s2 : slice u32) (sum : u32) (i : usize) : - Tot (result u32) (decreases (sum2_loop_decreases s s2 sum i)) +let rec sum2_loop + (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : + Tot (result u32) (decreases (sum2_loop_decreases s s2 sum0 i)) = let i0 = slice_len u32 s in if i < i0 then - let* i1 = slice_index_shared u32 s i in - let* i2 = slice_index_shared u32 s2 i in + let* i1 = slice_index_usize u32 s i in + let* i2 = slice_index_usize u32 s2 i in let* i3 = u32_add i1 i2 in - let* sum0 = u32_add sum i3 in + let* sum1 = u32_add sum0 i3 in let* i4 = usize_add i 1 in - sum2_loop_fwd s s2 sum0 i4 - else Return sum + sum2_loop s s2 sum1 i4 + else Return sum0 (** [array::sum2]: forward function *) -let sum2_fwd (s : slice u32) (s2 : slice u32) : result u32 = +let sum2 (s : slice u32) (s2 : slice u32) : result u32 = let i = slice_len u32 s in let i0 = slice_len u32 s2 in - if not (i = i0) then Fail Failure else sum2_loop_fwd s s2 0 0 + if not (i = i0) then Fail Failure else sum2_loop s s2 0 0 (** [array::f0]: forward function *) -let f0_fwd : result unit = - let* s = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 1; 2 ]) in - let* s0 = slice_index_mut_back u32 s 0 1 in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 1; 2 ]) s0 in +let f0 : result unit = + let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in + let* s0 = slice_update_usize u32 s 0 1 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 1; 2 ]) s0 in Return () (** [array::f1]: forward function *) -let f1_fwd : result unit = - let* _ = array_index_mut_back u32 2 (mk_array u32 2 [ 1; 2 ]) 0 1 in - Return () +let f1 : result unit = + let* _ = array_update_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 1 in Return () (** [array::f2]: forward function *) -let f2_fwd (i : u32) : result unit = +let f2 (i : u32) : result unit = Return () (** [array::f4]: forward function *) -let f4_fwd (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - array_subslice_shared u32 32 x (Mkrange y z) +let f4 (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = + core_array_Array_index u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } (** [array::f3]: forward function *) -let f3_fwd : result u32 = - let* i = array_index_shared u32 2 (mk_array u32 2 [ 1; 2 ]) 0 in - let* _ = f2_fwd i in - let* s = array_to_slice_shared u32 2 (mk_array u32 2 [ 1; 2 ]) in - let* s0 = - f4_fwd - (mk_array u32 32 [ - 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; - 0; 0; 0; 0; 0; 0; 0; 0 - ]) 16 18 in - sum2_fwd s s0 +let f3 : result u32 = + let* i = array_index_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 in + let* _ = f2 i in + let b = array_repeat u32 32 0 in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in + let* s0 = f4 b 16 18 in + sum2 s s0 + +(** [array::SZ] *) +let sz_body : result usize = Return 32 +let sz_c : usize = eval_global sz_body + +(** [array::f5]: forward function *) +let f5 (x : array u32 32) : result u32 = + array_index_usize u32 32 x 0 (** [array::ite]: forward function *) -let ite_fwd : result unit = - let* s = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* s0 = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in +let ite : result unit = + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in let* s1 = index_mut_slice_u32_0_back s0 in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in let* s2 = index_mut_slice_u32_0_back s in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 0; 0 ]) s2 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s2 in Return () diff --git a/tests/fstar/array/Array.Types.fst b/tests/fstar/array/Array.Types.fst index 5e8e81d8..4e8d5566 100644 --- a/tests/fstar/array/Array.Types.fst +++ b/tests/fstar/array/Array.Types.fst @@ -5,6 +5,6 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [array::T] *) -type t_t = | TA : t_t | TB : t_t +(** [array::AB] *) +type aB_t = | AB_A : aB_t | AB_B : aB_t diff --git a/tests/fstar/array/Primitives.fst b/tests/fstar/array/Primitives.fst index 9db82069..3297803c 100644 --- a/tests/fstar/array/Primitives.fst +++ b/tests/fstar/array/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -169,17 +187,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize @@ -231,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -259,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -278,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -295,55 +389,54 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -358,18 +451,279 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/betree/BetreeMain.Clauses.Template.fst b/tests/fstar/betree/BetreeMain.Clauses.Template.fst index 823df03a..8722f0bf 100644 --- a/tests/fstar/betree/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree/BetreeMain.Clauses.Template.fst @@ -8,95 +8,95 @@ open BetreeMain.Types (** [betree_main::betree::List::{1}::len]: decreases clause *) unfold -let betree_list_len_decreases (t : Type0) (self : betree_list_t t) : nat = +let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : nat = admit () (** [betree_main::betree::List::{1}::split_at]: decreases clause *) unfold -let betree_list_split_at_decreases (t : Type0) (self : betree_list_t t) +let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = admit () (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_list_partition_at_pivot_decreases (t : Type0) - (self : betree_list_t (u64 & t)) (pivot : u64) : nat = +let betree_List_partition_at_pivot_decreases (t : Type0) + (self : betree_List_t (u64 & t)) (pivot : u64) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) unfold -let betree_node_lookup_first_message_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_lookup_first_message_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) unfold -let betree_node_apply_upserts_decreases - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let betree_Node_apply_upserts_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) unfold -let betree_node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : nat = +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = admit () (** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) unfold -let betree_internal_lookup_in_children_decreases (self : betree_internal_t) +let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::lookup]: decreases clause *) unfold -let betree_node_lookup_decreases (self : betree_node_t) (key : u64) +let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) unfold -let betree_node_filter_messages_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_filter_messages_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) unfold -let betree_node_lookup_first_message_after_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_lookup_first_message_after_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: decreases clause *) unfold -let betree_node_apply_messages_to_internal_decreases - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_apply_messages_to_internal_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) unfold -let betree_node_lookup_mut_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : nat = +let betree_Node_lookup_mut_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: decreases clause *) unfold -let betree_node_apply_messages_to_leaf_decreases - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_apply_messages_to_leaf_decreases + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Internal::{4}::flush]: decreases clause *) unfold -let betree_internal_flush_decreases (self : betree_internal_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat = +let betree_Internal_flush_decreases (self : betree_Internal_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) unfold -let betree_node_apply_messages_decreases (self : betree_node_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat = +let betree_Node_apply_messages_decreases (self : betree_Node_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () diff --git a/tests/fstar/betree/BetreeMain.Clauses.fst b/tests/fstar/betree/BetreeMain.Clauses.fst index 07484711..cda7b920 100644 --- a/tests/fstar/betree/BetreeMain.Clauses.fst +++ b/tests/fstar/betree/BetreeMain.Clauses.fst @@ -8,8 +8,8 @@ open BetreeMain.Types (*** Well-founded relations *) (* We had a few issues when proving termination of the mutually recursive functions: - * - betree_internal_flush - * - betree_node_apply_messages + * - betree_Internal_flush + * - betree_Node_apply_messages * * The quantity which effectively decreases is: * (betree_size, messages_length) @@ -103,108 +103,108 @@ let wf_nat_pair_lem (p0 p1 : nat_pair) : (** [betree_main::betree::List::{1}::len]: decreases clause *) unfold -let betree_list_len_decreases (t : Type0) (self : betree_list_t t) : betree_list_t t = +let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : betree_List_t t = self (** [betree_main::betree::List::{1}::split_at]: decreases clause *) unfold -let betree_list_split_at_decreases (t : Type0) (self : betree_list_t t) +let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = n (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_list_partition_at_pivot_decreases (t : Type0) - (self : betree_list_t (u64 & t)) (pivot : u64) : betree_list_t (u64 & t) = +let betree_List_partition_at_pivot_decreases (t : Type0) + (self : betree_List_t (u64 & t)) (pivot : u64) : betree_List_t (u64 & t) = self (** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) unfold -let betree_node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : betree_list_t (u64 & u64) = +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : betree_List_t (u64 & u64) = bindings (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) unfold -let betree_node_lookup_first_message_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_lookup_first_message_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) unfold -let betree_node_apply_upserts_decreases - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) - (key : u64) (st : state) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_upserts_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) + (key : u64) (st : state) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) unfold -let betree_internal_lookup_in_children_decreases (self : betree_internal_t) - (key : u64) (st : state) : betree_internal_t = +let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) + (key : u64) (st : state) : betree_Internal_t = self (** [betree_main::betree::Node::{5}::lookup]: decreases clause *) unfold -let betree_node_lookup_decreases (self : betree_node_t) (key : u64) - (st : state) : betree_node_t = +let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) + (st : state) : betree_Node_t = self (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) unfold -let betree_node_lookup_mut_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : betree_list_t (u64 & u64) = +let betree_Node_lookup_mut_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : betree_List_t (u64 & u64) = bindings unfold -let betree_node_apply_messages_to_leaf_decreases - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_messages_to_leaf_decreases + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = new_msgs (** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) unfold -let betree_node_filter_messages_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_filter_messages_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) unfold -let betree_node_lookup_first_message_after_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_lookup_first_message_after_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs -let betree_node_apply_messages_to_internal_decreases - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_messages_to_internal_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = new_msgs (*** Decrease clauses - nat_pair *) /// The following decrease clauses use the [nat_pair] definition and the well-founded /// relation proven above. -let rec betree_size (bt : betree_node_t) : nat = +let rec betree_size (bt : betree_Node_t) : nat = match bt with - | BetreeNodeInternal node -> 1 + betree_internal_size node - | BetreeNodeLeaf _ -> 1 + | Betree_Node_Internal node -> 1 + betree_Internal_size node + | Betree_Node_Leaf _ -> 1 -and betree_internal_size (node : betree_internal_t) : nat = - 1 + betree_size node.betree_internal_left + betree_size node.betree_internal_right +and betree_Internal_size (node : betree_Internal_t) : nat = + 1 + betree_size node.left + betree_size node.right -let rec betree_list_len (#a : Type0) (ls : betree_list_t a) : nat = +let rec betree_List_len (#a : Type0) (ls : betree_List_t a) : nat = match ls with - | BetreeListCons _ tl -> 1 + betree_list_len tl - | BetreeListNil -> 0 + | Betree_List_Cons _ tl -> 1 + betree_List_len tl + | Betree_List_Nil -> 0 (** [betree_main::betree::Internal::{4}::flush]: decreases clause *) unfold -let betree_internal_flush_decreases (self : betree_internal_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat_pair = - (|betree_internal_size self, 0|) +let betree_Internal_flush_decreases (self : betree_Internal_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat_pair = + (|betree_Internal_size self, 0|) (** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) unfold -let betree_node_apply_messages_decreases (self : betree_node_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat_pair = - (|betree_size self, betree_list_len msgs|) +let betree_Node_apply_messages_decreases (self : betree_Node_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : nat_pair = + (|betree_size self, betree_List_len msgs|) diff --git a/tests/fstar/betree/BetreeMain.Funs.fst b/tests/fstar/betree/BetreeMain.Funs.fst index 847dc865..d2bf5c7c 100644 --- a/tests/fstar/betree/BetreeMain.Funs.fst +++ b/tests/fstar/betree/BetreeMain.Funs.fst @@ -9,35 +9,35 @@ include BetreeMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree::load_internal_node]: forward function *) -let betree_load_internal_node_fwd +let betree_load_internal_node (id : u64) (st : state) : - result (state & (betree_list_t (u64 & betree_message_t))) + result (state & (betree_List_t (u64 & betree_Message_t))) = - betree_utils_load_internal_node_fwd id st + betree_utils_load_internal_node id st (** [betree_main::betree::store_internal_node]: forward function *) -let betree_store_internal_node_fwd - (id : u64) (content : betree_list_t (u64 & betree_message_t)) (st : state) : +let betree_store_internal_node + (id : u64) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : result (state & unit) = - let* (st0, _) = betree_utils_store_internal_node_fwd id content st in + let* (st0, _) = betree_utils_store_internal_node id content st in Return (st0, ()) (** [betree_main::betree::load_leaf_node]: forward function *) -let betree_load_leaf_node_fwd - (id : u64) (st : state) : result (state & (betree_list_t (u64 & u64))) = - betree_utils_load_leaf_node_fwd id st +let betree_load_leaf_node + (id : u64) (st : state) : result (state & (betree_List_t (u64 & u64))) = + betree_utils_load_leaf_node id st (** [betree_main::betree::store_leaf_node]: forward function *) -let betree_store_leaf_node_fwd - (id : u64) (content : betree_list_t (u64 & u64)) (st : state) : +let betree_store_leaf_node + (id : u64) (content : betree_List_t (u64 & u64)) (st : state) : result (state & unit) = - let* (st0, _) = betree_utils_store_leaf_node_fwd id content st in + let* (st0, _) = betree_utils_store_leaf_node id content st in Return (st0, ()) (** [betree_main::betree::fresh_node_id]: forward function *) -let betree_fresh_node_id_fwd (counter : u64) : result u64 = +let betree_fresh_node_id (counter : u64) : result u64 = let* _ = u64_add counter 1 in Return counter (** [betree_main::betree::fresh_node_id]: backward function 0 *) @@ -45,976 +45,909 @@ let betree_fresh_node_id_back (counter : u64) : result u64 = u64_add counter 1 (** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) -let betree_node_id_counter_new_fwd : result betree_node_id_counter_t = - Return { betree_node_id_counter_next_node_id = 0 } +let betree_NodeIdCounter_new : result betree_NodeIdCounter_t = + Return { next_node_id = 0 } (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) -let betree_node_id_counter_fresh_id_fwd - (self : betree_node_id_counter_t) : result u64 = - let* _ = u64_add self.betree_node_id_counter_next_node_id 1 in - Return self.betree_node_id_counter_next_node_id +let betree_NodeIdCounter_fresh_id + (self : betree_NodeIdCounter_t) : result u64 = + let* _ = u64_add self.next_node_id 1 in Return self.next_node_id (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) -let betree_node_id_counter_fresh_id_back - (self : betree_node_id_counter_t) : result betree_node_id_counter_t = - let* i = u64_add self.betree_node_id_counter_next_node_id 1 in - Return { betree_node_id_counter_next_node_id = i } - -(** [core::num::u64::{9}::MAX] *) -let core_num_u64_max_body : result u64 = Return 18446744073709551615 -let core_num_u64_max_c : u64 = eval_global core_num_u64_max_body +let betree_NodeIdCounter_fresh_id_back + (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t = + let* i = u64_add self.next_node_id 1 in Return { next_node_id = i } (** [betree_main::betree::upsert_update]: forward function *) -let betree_upsert_update_fwd - (prev : option u64) (st : betree_upsert_fun_state_t) : result u64 = +let betree_upsert_update + (prev : option u64) (st : betree_UpsertFunState_t) : result u64 = begin match prev with | None -> begin match st with - | BetreeUpsertFunStateAdd v -> Return v - | BetreeUpsertFunStateSub i -> Return 0 + | Betree_UpsertFunState_Add v -> Return v + | Betree_UpsertFunState_Sub i -> Return 0 end | Some prev0 -> begin match st with - | BetreeUpsertFunStateAdd v -> - let* margin = u64_sub core_num_u64_max_c prev0 in - if margin >= v then u64_add prev0 v else Return core_num_u64_max_c - | BetreeUpsertFunStateSub v -> + | Betree_UpsertFunState_Add v -> + let* margin = u64_sub core_u64_max prev0 in + if margin >= v then u64_add prev0 v else Return core_u64_max + | Betree_UpsertFunState_Sub v -> if prev0 >= v then u64_sub prev0 v else Return 0 end end (** [betree_main::betree::List::{1}::len]: forward function *) -let rec betree_list_len_fwd - (t : Type0) (self : betree_list_t t) : - Tot (result u64) (decreases (betree_list_len_decreases t self)) +let rec betree_List_len + (t : Type0) (self : betree_List_t t) : + Tot (result u64) (decreases (betree_List_len_decreases t self)) = begin match self with - | BetreeListCons x tl -> let* i = betree_list_len_fwd t tl in u64_add 1 i - | BetreeListNil -> Return 0 + | Betree_List_Cons x tl -> let* i = betree_List_len t tl in u64_add 1 i + | Betree_List_Nil -> Return 0 end (** [betree_main::betree::List::{1}::split_at]: forward function *) -let rec betree_list_split_at_fwd - (t : Type0) (self : betree_list_t t) (n : u64) : - Tot (result ((betree_list_t t) & (betree_list_t t))) - (decreases (betree_list_split_at_decreases t self n)) +let rec betree_List_split_at + (t : Type0) (self : betree_List_t t) (n : u64) : + Tot (result ((betree_List_t t) & (betree_List_t t))) + (decreases (betree_List_split_at_decreases t self n)) = if n = 0 - then Return (BetreeListNil, self) + then Return (Betree_List_Nil, self) else begin match self with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let* i = u64_sub n 1 in - let* p = betree_list_split_at_fwd t tl i in + let* p = betree_List_split_at t tl i in let (ls0, ls1) = p in let l = ls0 in - Return (BetreeListCons hd l, ls1) - | BetreeListNil -> Fail Failure + Return (Betree_List_Cons hd l, ls1) + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_list_push_front_fwd_back - (t : Type0) (self : betree_list_t t) (x : t) : result (betree_list_t t) = - let tl = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_push_front + (t : Type0) (self : betree_List_t t) (x : t) : result (betree_List_t t) = + let tl = core_mem_replace (betree_List_t t) self Betree_List_Nil in let l = tl in - Return (BetreeListCons x l) + Return (Betree_List_Cons x l) (** [betree_main::betree::List::{1}::pop_front]: forward function *) -let betree_list_pop_front_fwd (t : Type0) (self : betree_list_t t) : result t = - let ls = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = + let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with - | BetreeListCons x tl -> Return x - | BetreeListNil -> Fail Failure + | Betree_List_Cons x tl -> Return x + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) -let betree_list_pop_front_back - (t : Type0) (self : betree_list_t t) : result (betree_list_t t) = - let ls = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_pop_front_back + (t : Type0) (self : betree_List_t t) : result (betree_List_t t) = + let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with - | BetreeListCons x tl -> Return tl - | BetreeListNil -> Fail Failure + | Betree_List_Cons x tl -> Return tl + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::hd]: forward function *) -let betree_list_hd_fwd (t : Type0) (self : betree_list_t t) : result t = +let betree_List_hd (t : Type0) (self : betree_List_t t) : result t = begin match self with - | BetreeListCons hd l -> Return hd - | BetreeListNil -> Fail Failure + | Betree_List_Cons hd l -> Return hd + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{2}::head_has_key]: forward function *) -let betree_list_head_has_key_fwd - (t : Type0) (self : betree_list_t (u64 & t)) (key : u64) : result bool = +let betree_List_head_has_key + (t : Type0) (self : betree_List_t (u64 & t)) (key : u64) : result bool = begin match self with - | BetreeListCons hd l -> let (i, _) = hd in Return (i = key) - | BetreeListNil -> Return false + | Betree_List_Cons hd l -> let (i, _) = hd in Return (i = key) + | Betree_List_Nil -> Return false end (** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -let rec betree_list_partition_at_pivot_fwd - (t : Type0) (self : betree_list_t (u64 & t)) (pivot : u64) : - Tot (result ((betree_list_t (u64 & t)) & (betree_list_t (u64 & t)))) - (decreases (betree_list_partition_at_pivot_decreases t self pivot)) +let rec betree_List_partition_at_pivot + (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : + Tot (result ((betree_List_t (u64 & t)) & (betree_List_t (u64 & t)))) + (decreases (betree_List_partition_at_pivot_decreases t self pivot)) = begin match self with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, x) = hd in if i >= pivot - then Return (BetreeListNil, BetreeListCons (i, x) tl) + then Return (Betree_List_Nil, Betree_List_Cons (i, x) tl) else - let* p = betree_list_partition_at_pivot_fwd t tl pivot in + let* p = betree_List_partition_at_pivot t tl pivot in let (ls0, ls1) = p in let l = ls0 in - Return (BetreeListCons (i, x) l, ls1) - | BetreeListNil -> Return (BetreeListNil, BetreeListNil) + Return (Betree_List_Cons (i, x) l, ls1) + | Betree_List_Nil -> Return (Betree_List_Nil, Betree_List_Nil) end (** [betree_main::betree::Leaf::{3}::split]: forward function *) -let betree_leaf_split_fwd - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result (state & betree_internal_t) + result (state & betree_Internal_t) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* p0 = betree_list_hd_fwd (u64 & u64) content1 in + let* p0 = betree_List_hd (u64 & u64) content1 in let (pivot, _) = p0 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st0, _) = betree_store_leaf_node_fwd id0 content0 st in - let* (st1, _) = betree_store_leaf_node_fwd id1 content1 st0 in - let n = BetreeNodeLeaf - { betree_leaf_id = id0; betree_leaf_size = params.betree_params_split_size - } in - let n0 = BetreeNodeLeaf - { betree_leaf_id = id1; betree_leaf_size = params.betree_params_split_size - } in - Return (st1, - { - betree_internal_id = self.betree_leaf_id; - betree_internal_pivot = pivot; - betree_internal_left = n; - betree_internal_right = n0 - }) + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st0, _) = betree_store_leaf_node id0 content0 st in + let* (st1, _) = betree_store_leaf_node id1 content1 st0 in + let n = Betree_Node_Leaf { id = id0; size = params.split_size } in + let n0 = Betree_Node_Leaf { id = id1; size = params.split_size } in + Return (st1, { id = self.id; pivot = pivot; left = n; right = n0 }) (** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) -let betree_leaf_split_back - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split_back + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result betree_node_id_counter_t + result betree_NodeIdCounter_t = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* _ = betree_list_hd_fwd (u64 & u64) content1 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st0, _) = betree_store_leaf_node_fwd id0 content0 st in - let* _ = betree_store_leaf_node_fwd id1 content1 st0 in - betree_node_id_counter_fresh_id_back node_id_cnt0 + let* _ = betree_List_hd (u64 & u64) content1 in + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st0, _) = betree_store_leaf_node id0 content0 st in + let* _ = betree_store_leaf_node id1 content1 st0 in + betree_NodeIdCounter_fresh_id_back node_id_cnt0 (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) -let rec betree_node_lookup_first_message_for_key_fwd - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_for_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_for_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons x next_msgs -> + | Betree_List_Cons x next_msgs -> let (i, m) = x in if i >= key - then Return (BetreeListCons (i, m) next_msgs) - else betree_node_lookup_first_message_for_key_fwd key next_msgs - | BetreeListNil -> Return BetreeListNil + then Return (Betree_List_Cons (i, m) next_msgs) + else betree_Node_lookup_first_message_for_key key next_msgs + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) -let rec betree_node_lookup_first_message_for_key_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) - (ret : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_for_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_for_key_back + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) + (ret : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons x next_msgs -> + | Betree_List_Cons x next_msgs -> let (i, m) = x in if i >= key then Return ret else let* next_msgs0 = - betree_node_lookup_first_message_for_key_back key next_msgs ret in - Return (BetreeListCons (i, m) next_msgs0) - | BetreeListNil -> Return ret + betree_Node_lookup_first_message_for_key_back key next_msgs ret in + Return (Betree_List_Cons (i, m) next_msgs0) + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) -let rec betree_node_apply_upserts_fwd - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let rec betree_Node_apply_upserts + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : Tot (result (state & u64)) - (decreases (betree_node_apply_upserts_decreases msgs prev key st)) + (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_list_head_has_key_fwd betree_message_t msgs key in + let* b = betree_List_head_has_key betree_Message_t msgs key in if b then - let* msg = betree_list_pop_front_fwd (u64 & betree_message_t) msgs in + let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in let (_, m) = msg in begin match m with - | BetreeMessageInsert i -> Fail Failure - | BetreeMessageDelete -> Fail Failure - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd prev s in - let* msgs0 = betree_list_pop_front_back (u64 & betree_message_t) msgs in - betree_node_apply_upserts_fwd msgs0 (Some v) key st + | Betree_Message_Insert i -> Fail Failure + | Betree_Message_Delete -> Fail Failure + | Betree_Message_Upsert s -> + let* v = betree_upsert_update prev s in + let* msgs0 = betree_List_pop_front_back (u64 & betree_Message_t) msgs in + betree_Node_apply_upserts msgs0 (Some v) key st end else - let* (st0, v) = core_option_option_unwrap_fwd u64 prev st in + let* (st0, v) = core_option_Option_unwrap u64 prev st in let* _ = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs (key, - BetreeMessageInsert v) in + betree_List_push_front (u64 & betree_Message_t) msgs (key, + Betree_Message_Insert v) in Return (st0, v) (** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) -let rec betree_node_apply_upserts_back - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let rec betree_Node_apply_upserts_back + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_apply_upserts_decreases msgs prev key st)) + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_list_head_has_key_fwd betree_message_t msgs key in + let* b = betree_List_head_has_key betree_Message_t msgs key in if b then - let* msg = betree_list_pop_front_fwd (u64 & betree_message_t) msgs in + let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in let (_, m) = msg in begin match m with - | BetreeMessageInsert i -> Fail Failure - | BetreeMessageDelete -> Fail Failure - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd prev s in - let* msgs0 = betree_list_pop_front_back (u64 & betree_message_t) msgs in - betree_node_apply_upserts_back msgs0 (Some v) key st + | Betree_Message_Insert i -> Fail Failure + | Betree_Message_Delete -> Fail Failure + | Betree_Message_Upsert s -> + let* v = betree_upsert_update prev s in + let* msgs0 = betree_List_pop_front_back (u64 & betree_Message_t) msgs in + betree_Node_apply_upserts_back msgs0 (Some v) key st end else - let* (_, v) = core_option_option_unwrap_fwd u64 prev st in - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs (key, - BetreeMessageInsert v) + let* (_, v) = core_option_Option_unwrap u64 prev st in + betree_List_push_front (u64 & betree_Message_t) msgs (key, + Betree_Message_Insert v) (** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) -let rec betree_node_lookup_in_bindings_fwd - (key : u64) (bindings : betree_list_t (u64 & u64)) : +let rec betree_Node_lookup_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (option u64)) - (decreases (betree_node_lookup_in_bindings_decreases key bindings)) + (decreases (betree_Node_lookup_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i = key then Return (Some i0) - else - if i > key - then Return None - else betree_node_lookup_in_bindings_fwd key tl - | BetreeListNil -> Return None + else if i > key then Return None else betree_Node_lookup_in_bindings key tl + | Betree_List_Nil -> Return None end (** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) -let rec betree_internal_lookup_in_children_fwd - (self : betree_internal_t) (key : u64) (st : state) : +let rec betree_Internal_lookup_in_children + (self : betree_Internal_t) (key : u64) (st : state) : Tot (result (state & (option u64))) - (decreases (betree_internal_lookup_in_children_decreases self key st)) + (decreases (betree_Internal_lookup_in_children_decreases self key st)) = - if key < self.betree_internal_pivot - then betree_node_lookup_fwd self.betree_internal_left key st - else betree_node_lookup_fwd self.betree_internal_right key st + if key < self.pivot + then betree_Node_lookup self.left key st + else betree_Node_lookup self.right key st (** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) -and betree_internal_lookup_in_children_back - (self : betree_internal_t) (key : u64) (st : state) : - Tot (result betree_internal_t) - (decreases (betree_internal_lookup_in_children_decreases self key st)) +and betree_Internal_lookup_in_children_back + (self : betree_Internal_t) (key : u64) (st : state) : + Tot (result betree_Internal_t) + (decreases (betree_Internal_lookup_in_children_decreases self key st)) = - if key < self.betree_internal_pivot + if key < self.pivot then - let* n = betree_node_lookup_back self.betree_internal_left key st in - Return { self with betree_internal_left = n } + let* n = betree_Node_lookup_back self.left key st in + Return { self with left = n } else - let* n = betree_node_lookup_back self.betree_internal_right key st in - Return { self with betree_internal_right = n } + let* n = betree_Node_lookup_back self.right key st in + Return { self with right = n } (** [betree_main::betree::Node::{5}::lookup]: forward function *) -and betree_node_lookup_fwd - (self : betree_node_t) (key : u64) (st : state) : +and betree_Node_lookup + (self : betree_Node_t) (key : u64) (st : state) : Tot (result (state & (option u64))) - (decreases (betree_node_lookup_decreases self key st)) + (decreases (betree_Node_lookup_decreases self key st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, msgs) = betree_load_internal_node_fwd node.betree_internal_id st - in - let* pending = betree_node_lookup_first_message_for_key_fwd key msgs in + | Betree_Node_Internal node -> + let* (st0, msgs) = betree_load_internal_node node.id st in + let* pending = betree_Node_lookup_first_message_for_key key msgs in begin match pending with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, msg) = p in if k <> key then - let* (st1, opt) = betree_internal_lookup_in_children_fwd node key st0 - in + let* (st1, o) = betree_Internal_lookup_in_children node key st0 in let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, msg) l) in - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, msg) l) in + Return (st1, o) else begin match msg with - | BetreeMessageInsert v -> + | Betree_Message_Insert v -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageInsert v) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l) in Return (st0, Some v) - | BetreeMessageDelete -> + | Betree_Message_Delete -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageDelete) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l) in Return (st0, None) - | BetreeMessageUpsert ufs -> - let* (st1, v) = betree_internal_lookup_in_children_fwd node key st0 - in + | Betree_Message_Upsert ufs -> + let* (st1, v) = betree_Internal_lookup_in_children node key st0 in let* (st2, v0) = - betree_node_apply_upserts_fwd (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in - let* node0 = betree_internal_lookup_in_children_back node key st0 in + betree_Node_apply_upserts (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in + let* node0 = betree_Internal_lookup_in_children_back node key st0 in let* pending0 = - betree_node_apply_upserts_back (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in + betree_Node_apply_upserts_back (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in let* msgs0 = - betree_node_lookup_first_message_for_key_back key msgs pending0 in - let* (st3, _) = - betree_store_internal_node_fwd node0.betree_internal_id msgs0 st2 - in + betree_Node_lookup_first_message_for_key_back key msgs pending0 in + let* (st3, _) = betree_store_internal_node node0.id msgs0 st2 in Return (st3, Some v0) end - | BetreeListNil -> - let* (st1, opt) = betree_internal_lookup_in_children_fwd node key st0 in + | Betree_List_Nil -> + let* (st1, o) = betree_Internal_lookup_in_children node key st0 in let* _ = - betree_node_lookup_first_message_for_key_back key msgs BetreeListNil in - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back key msgs Betree_List_Nil + in + Return (st1, o) end - | BetreeNodeLeaf node -> - let* (st0, bindings) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* opt = betree_node_lookup_in_bindings_fwd key bindings in - Return (st0, opt) + | Betree_Node_Leaf node -> + let* (st0, bindings) = betree_load_leaf_node node.id st in + let* o = betree_Node_lookup_in_bindings key bindings in + Return (st0, o) end (** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) -and betree_node_lookup_back - (self : betree_node_t) (key : u64) (st : state) : - Tot (result betree_node_t) - (decreases (betree_node_lookup_decreases self key st)) +and betree_Node_lookup_back + (self : betree_Node_t) (key : u64) (st : state) : + Tot (result betree_Node_t) + (decreases (betree_Node_lookup_decreases self key st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, msgs) = betree_load_internal_node_fwd node.betree_internal_id st - in - let* pending = betree_node_lookup_first_message_for_key_fwd key msgs in + | Betree_Node_Internal node -> + let* (st0, msgs) = betree_load_internal_node node.id st in + let* pending = betree_Node_lookup_first_message_for_key key msgs in begin match pending with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, msg) = p in if k <> key then let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, msg) l) in - let* node0 = betree_internal_lookup_in_children_back node key st0 in - Return (BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, msg) l) in + let* node0 = betree_Internal_lookup_in_children_back node key st0 in + Return (Betree_Node_Internal node0) else begin match msg with - | BetreeMessageInsert v -> + | Betree_Message_Insert v -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageInsert v) l) in - Return (BetreeNodeInternal node) - | BetreeMessageDelete -> + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l) in + Return (Betree_Node_Internal node) + | Betree_Message_Delete -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageDelete) l) in - Return (BetreeNodeInternal node) - | BetreeMessageUpsert ufs -> - let* (st1, v) = betree_internal_lookup_in_children_fwd node key st0 - in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l) in + Return (Betree_Node_Internal node) + | Betree_Message_Upsert ufs -> + let* (st1, v) = betree_Internal_lookup_in_children node key st0 in let* (st2, _) = - betree_node_apply_upserts_fwd (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in - let* node0 = betree_internal_lookup_in_children_back node key st0 in + betree_Node_apply_upserts (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in + let* node0 = betree_Internal_lookup_in_children_back node key st0 in let* pending0 = - betree_node_apply_upserts_back (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in + betree_Node_apply_upserts_back (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in let* msgs0 = - betree_node_lookup_first_message_for_key_back key msgs pending0 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id msgs0 st2 - in - Return (BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back key msgs pending0 in + let* _ = betree_store_internal_node node0.id msgs0 st2 in + Return (Betree_Node_Internal node0) end - | BetreeListNil -> + | Betree_List_Nil -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs BetreeListNil in - let* node0 = betree_internal_lookup_in_children_back node key st0 in - Return (BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back key msgs Betree_List_Nil + in + let* node0 = betree_Internal_lookup_in_children_back node key st0 in + Return (Betree_Node_Internal node0) end - | BetreeNodeLeaf node -> - let* (_, bindings) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* _ = betree_node_lookup_in_bindings_fwd key bindings in - Return (BetreeNodeLeaf node) + | Betree_Node_Leaf node -> + let* (_, bindings) = betree_load_leaf_node node.id st in + let* _ = betree_Node_lookup_in_bindings key bindings in + Return (Betree_Node_Leaf node) end (** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_filter_messages_for_key_fwd_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_filter_messages_for_key_decreases key msgs)) +let rec betree_Node_filter_messages_for_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_filter_messages_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, m) = p in if k = key then let* msgs0 = - betree_list_pop_front_back (u64 & betree_message_t) (BetreeListCons (k, - m) l) in - betree_node_filter_messages_for_key_fwd_back key msgs0 - else Return (BetreeListCons (k, m) l) - | BetreeListNil -> Return BetreeListNil + betree_List_pop_front_back (u64 & betree_Message_t) (Betree_List_Cons + (k, m) l) in + betree_Node_filter_messages_for_key key msgs0 + else Return (Betree_List_Cons (k, m) l) + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) -let rec betree_node_lookup_first_message_after_key_fwd - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_after_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_after_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_after_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p next_msgs -> + | Betree_List_Cons p next_msgs -> let (k, m) = p in if k = key - then betree_node_lookup_first_message_after_key_fwd key next_msgs - else Return (BetreeListCons (k, m) next_msgs) - | BetreeListNil -> Return BetreeListNil + then betree_Node_lookup_first_message_after_key key next_msgs + else Return (Betree_List_Cons (k, m) next_msgs) + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) -let rec betree_node_lookup_first_message_after_key_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) - (ret : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_after_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_after_key_back + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) + (ret : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_after_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p next_msgs -> + | Betree_List_Cons p next_msgs -> let (k, m) = p in if k = key then let* next_msgs0 = - betree_node_lookup_first_message_after_key_back key next_msgs ret in - Return (BetreeListCons (k, m) next_msgs0) + betree_Node_lookup_first_message_after_key_back key next_msgs ret in + Return (Betree_List_Cons (k, m) next_msgs0) else Return ret - | BetreeListNil -> Return ret + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_node_apply_to_internal_fwd_back - (msgs : betree_list_t (u64 & betree_message_t)) (key : u64) - (new_msg : betree_message_t) : - result (betree_list_t (u64 & betree_message_t)) +let betree_Node_apply_to_internal + (msgs : betree_List_t (u64 & betree_Message_t)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 & betree_Message_t)) = - let* msgs0 = betree_node_lookup_first_message_for_key_fwd key msgs in - let* b = betree_list_head_has_key_fwd betree_message_t msgs0 key in + let* msgs0 = betree_Node_lookup_first_message_for_key key msgs in + let* b = betree_List_head_has_key betree_Message_t msgs0 key in if b then begin match new_msg with - | BetreeMessageInsert i -> - let* msgs1 = betree_node_filter_messages_for_key_fwd_back key msgs0 in + | Betree_Message_Insert i -> + let* msgs1 = betree_Node_filter_messages_for_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert i) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageDelete -> - let* msgs1 = betree_node_filter_messages_for_key_fwd_back key msgs0 in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert i) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Delete -> + let* msgs1 = betree_Node_filter_messages_for_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageDelete) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageUpsert s -> - let* p = betree_list_hd_fwd (u64 & betree_message_t) msgs0 in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Delete) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Upsert s -> + let* p = betree_List_hd (u64 & betree_Message_t) msgs0 in let (_, m) = p in begin match m with - | BetreeMessageInsert prev -> - let* v = betree_upsert_update_fwd (Some prev) s in - let* msgs1 = betree_list_pop_front_back (u64 & betree_message_t) msgs0 + | Betree_Message_Insert prev -> + let* v = betree_upsert_update (Some prev) s in + let* msgs1 = betree_List_pop_front_back (u64 & betree_Message_t) msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert v) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageDelete -> - let* v = betree_upsert_update_fwd None s in - let* msgs1 = betree_list_pop_front_back (u64 & betree_message_t) msgs0 + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert v) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Delete -> + let* v = betree_upsert_update None s in + let* msgs1 = betree_List_pop_front_back (u64 & betree_Message_t) msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert v) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageUpsert ufs -> - let* msgs1 = betree_node_lookup_first_message_after_key_fwd key msgs0 - in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert v) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Upsert ufs -> + let* msgs1 = betree_Node_lookup_first_message_after_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageUpsert s) in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Upsert s) in let* msgs3 = - betree_node_lookup_first_message_after_key_back key msgs0 msgs2 in - betree_node_lookup_first_message_for_key_back key msgs msgs3 + betree_Node_lookup_first_message_after_key_back key msgs0 msgs2 in + betree_Node_lookup_first_message_for_key_back key msgs msgs3 end end else let* msgs1 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs0 (key, - new_msg) in - betree_node_lookup_first_message_for_key_back key msgs msgs1 + betree_List_push_front (u64 & betree_Message_t) msgs0 (key, new_msg) in + betree_Node_lookup_first_message_for_key_back key msgs msgs1 (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_apply_messages_to_internal_fwd_back - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_apply_messages_to_internal_decreases msgs new_msgs)) +let rec betree_Node_apply_messages_to_internal + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_apply_messages_to_internal_decreases msgs new_msgs)) = begin match new_msgs with - | BetreeListCons new_msg new_msgs_tl -> + | Betree_List_Cons new_msg new_msgs_tl -> let (i, m) = new_msg in - let* msgs0 = betree_node_apply_to_internal_fwd_back msgs i m in - betree_node_apply_messages_to_internal_fwd_back msgs0 new_msgs_tl - | BetreeListNil -> Return msgs + let* msgs0 = betree_Node_apply_to_internal msgs i m in + betree_Node_apply_messages_to_internal msgs0 new_msgs_tl + | Betree_List_Nil -> Return msgs end (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) -let rec betree_node_lookup_mut_in_bindings_fwd - (key : u64) (bindings : betree_list_t (u64 & u64)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_lookup_mut_in_bindings_decreases key bindings)) +let rec betree_Node_lookup_mut_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_lookup_mut_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i >= key - then Return (BetreeListCons (i, i0) tl) - else betree_node_lookup_mut_in_bindings_fwd key tl - | BetreeListNil -> Return BetreeListNil + then Return (Betree_List_Cons (i, i0) tl) + else betree_Node_lookup_mut_in_bindings key tl + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) -let rec betree_node_lookup_mut_in_bindings_back - (key : u64) (bindings : betree_list_t (u64 & u64)) - (ret : betree_list_t (u64 & u64)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_lookup_mut_in_bindings_decreases key bindings)) +let rec betree_Node_lookup_mut_in_bindings_back + (key : u64) (bindings : betree_List_t (u64 & u64)) + (ret : betree_List_t (u64 & u64)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_lookup_mut_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i >= key then Return ret else - let* tl0 = betree_node_lookup_mut_in_bindings_back key tl ret in - Return (BetreeListCons (i, i0) tl0) - | BetreeListNil -> Return ret + let* tl0 = betree_Node_lookup_mut_in_bindings_back key tl ret in + Return (Betree_List_Cons (i, i0) tl0) + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_node_apply_to_leaf_fwd_back - (bindings : betree_list_t (u64 & u64)) (key : u64) - (new_msg : betree_message_t) : - result (betree_list_t (u64 & u64)) +let betree_Node_apply_to_leaf + (bindings : betree_List_t (u64 & u64)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 & u64)) = - let* bindings0 = betree_node_lookup_mut_in_bindings_fwd key bindings in - let* b = betree_list_head_has_key_fwd u64 bindings0 key in + let* bindings0 = betree_Node_lookup_mut_in_bindings key bindings in + let* b = betree_List_head_has_key u64 bindings0 key in if b then - let* hd = betree_list_pop_front_fwd (u64 & u64) bindings0 in + let* hd = betree_List_pop_front (u64 & u64) bindings0 in begin match new_msg with - | BetreeMessageInsert v -> - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - let* bindings2 = - betree_list_push_front_fwd_back (u64 & u64) bindings1 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings2 - | BetreeMessageDelete -> - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 - | BetreeMessageUpsert s -> + | Betree_Message_Insert v -> + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + let* bindings2 = betree_List_push_front (u64 & u64) bindings1 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings2 + | Betree_Message_Delete -> + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Upsert s -> let (_, i) = hd in - let* v = betree_upsert_update_fwd (Some i) s in - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - let* bindings2 = - betree_list_push_front_fwd_back (u64 & u64) bindings1 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings2 + let* v = betree_upsert_update (Some i) s in + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + let* bindings2 = betree_List_push_front (u64 & u64) bindings1 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings2 end else begin match new_msg with - | BetreeMessageInsert v -> - let* bindings1 = - betree_list_push_front_fwd_back (u64 & u64) bindings0 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 - | BetreeMessageDelete -> - betree_node_lookup_mut_in_bindings_back key bindings bindings0 - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd None s in - let* bindings1 = - betree_list_push_front_fwd_back (u64 & u64) bindings0 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Insert v -> + let* bindings1 = betree_List_push_front (u64 & u64) bindings0 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Delete -> + betree_Node_lookup_mut_in_bindings_back key bindings bindings0 + | Betree_Message_Upsert s -> + let* v = betree_upsert_update None s in + let* bindings1 = betree_List_push_front (u64 & u64) bindings0 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 end (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_apply_messages_to_leaf_fwd_back - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_apply_messages_to_leaf_decreases bindings new_msgs)) +let rec betree_Node_apply_messages_to_leaf + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_apply_messages_to_leaf_decreases bindings new_msgs)) = begin match new_msgs with - | BetreeListCons new_msg new_msgs_tl -> + | Betree_List_Cons new_msg new_msgs_tl -> let (i, m) = new_msg in - let* bindings0 = betree_node_apply_to_leaf_fwd_back bindings i m in - betree_node_apply_messages_to_leaf_fwd_back bindings0 new_msgs_tl - | BetreeListNil -> Return bindings + let* bindings0 = betree_Node_apply_to_leaf bindings i m in + betree_Node_apply_messages_to_leaf bindings0 new_msgs_tl + | Betree_List_Nil -> Return bindings end (** [betree_main::betree::Internal::{4}::flush]: forward function *) -let rec betree_internal_flush_fwd - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : - Tot (result (state & (betree_list_t (u64 & betree_message_t)))) +let rec betree_Internal_flush + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : + Tot (result (state & (betree_List_t (u64 & betree_Message_t)))) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (_, node_id_cnt0) = - betree_node_apply_messages_back self.betree_internal_left params - node_id_cnt msgs_left st in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back self.left params node_id_cnt msgs_left st + in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt0 msgs_right st0 in + betree_Node_apply_messages self.right params node_id_cnt0 msgs_right + st0 in let* _ = - betree_node_apply_messages_back self.betree_internal_right params - node_id_cnt0 msgs_right st0 in - Return (st1, BetreeListNil) + betree_Node_apply_messages_back self.right params node_id_cnt0 + msgs_right st0 in + Return (st1, Betree_List_Nil) else Return (st0, msgs_right) else let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages self.right params node_id_cnt msgs_right st in let* _ = - betree_node_apply_messages_back self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages_back self.right params node_id_cnt msgs_right + st in Return (st0, msgs_left) (** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) -and betree_internal_flush_back - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : - Tot (result (betree_internal_t & betree_node_id_counter_t)) +and betree_Internal_flush_back + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : + Tot (result (betree_Internal_t & betree_NodeIdCounter_t)) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (n, node_id_cnt0) = - betree_node_apply_messages_back self.betree_internal_left params - node_id_cnt msgs_left st in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back self.left params node_id_cnt msgs_left st + in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (n0, node_id_cnt1) = - betree_node_apply_messages_back self.betree_internal_right params - node_id_cnt0 msgs_right st0 in - Return - ({ self with betree_internal_left = n; betree_internal_right = n0 }, - node_id_cnt1) - else Return ({ self with betree_internal_left = n }, node_id_cnt0) + betree_Node_apply_messages_back self.right params node_id_cnt0 + msgs_right st0 in + Return ({ self with left = n; right = n0 }, node_id_cnt1) + else Return ({ self with left = n }, node_id_cnt0) else let* (n, node_id_cnt0) = - betree_node_apply_messages_back self.betree_internal_right params - node_id_cnt msgs_right st in - Return ({ self with betree_internal_right = n }, node_id_cnt0) + betree_Node_apply_messages_back self.right params node_id_cnt msgs_right + st in + Return ({ self with right = n }, node_id_cnt0) (** [betree_main::betree::Node::{5}::apply_messages]: forward function *) -and betree_node_apply_messages_fwd - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : +and betree_Node_apply_messages + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : Tot (result (state & unit)) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st0, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st1, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st0 in + betree_Internal_flush node params node_id_cnt content0 st0 in let* (node0, _) = - betree_internal_flush_back node params node_id_cnt content0 st0 in - let* (st2, _) = - betree_store_internal_node_fwd node0.betree_internal_id content1 st1 in + betree_Internal_flush_back node params node_id_cnt content0 st0 in + let* (st2, _) = betree_store_internal_node node0.id content1 st1 in Return (st2, ()) else - let* (st1, _) = - betree_store_internal_node_fwd node.betree_internal_id content0 st0 in + let* (st1, _) = betree_store_internal_node node.id content0 st0 in Return (st1, ()) - | BetreeNodeLeaf node -> - let* (st0, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + | Betree_Node_Leaf node -> + let* (st0, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then - let* (st1, _) = - betree_leaf_split_fwd node content0 params node_id_cnt st0 in - let* (st2, _) = - betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st1 in + let* (st1, _) = betree_Leaf_split node content0 params node_id_cnt st0 in + let* (st2, _) = betree_store_leaf_node node.id Betree_List_Nil st1 in Return (st2, ()) else - let* (st1, _) = - betree_store_leaf_node_fwd node.betree_leaf_id content0 st0 in + let* (st1, _) = betree_store_leaf_node node.id content0 st0 in Return (st1, ()) end (** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) -and betree_node_apply_messages_back - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : - Tot (result (betree_node_t & betree_node_id_counter_t)) +and betree_Node_apply_messages_back + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : + Tot (result (betree_Node_t & betree_NodeIdCounter_t)) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st0, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st1, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st0 in + betree_Internal_flush node params node_id_cnt content0 st0 in let* (node0, node_id_cnt0) = - betree_internal_flush_back node params node_id_cnt content0 st0 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id content1 st1 in - Return (BetreeNodeInternal node0, node_id_cnt0) + betree_Internal_flush_back node params node_id_cnt content0 st0 in + let* _ = betree_store_internal_node node0.id content1 st1 in + Return (Betree_Node_Internal node0, node_id_cnt0) else - let* _ = - betree_store_internal_node_fwd node.betree_internal_id content0 st0 in - Return (BetreeNodeInternal node, node_id_cnt) - | BetreeNodeLeaf node -> - let* (st0, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + let* _ = betree_store_internal_node node.id content0 st0 in + Return (Betree_Node_Internal node, node_id_cnt) + | Betree_Node_Leaf node -> + let* (st0, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then let* (st1, new_node) = - betree_leaf_split_fwd node content0 params node_id_cnt st0 in - let* _ = betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st1 - in + betree_Leaf_split node content0 params node_id_cnt st0 in + let* _ = betree_store_leaf_node node.id Betree_List_Nil st1 in let* node_id_cnt0 = - betree_leaf_split_back node content0 params node_id_cnt st0 in - Return (BetreeNodeInternal new_node, node_id_cnt0) + betree_Leaf_split_back node content0 params node_id_cnt st0 in + Return (Betree_Node_Internal new_node, node_id_cnt0) else - let* _ = betree_store_leaf_node_fwd node.betree_leaf_id content0 st0 in - Return (BetreeNodeLeaf { node with betree_leaf_size = len }, node_id_cnt) + let* _ = betree_store_leaf_node node.id content0 st0 in + Return (Betree_Node_Leaf { node with size = len }, node_id_cnt) end (** [betree_main::betree::Node::{5}::apply]: forward function *) -let betree_node_apply_fwd - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) : +let betree_Node_apply + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : result (state & unit) = - let l = BetreeListNil in + let l = Betree_List_Nil in let* (st0, _) = - betree_node_apply_messages_fwd self params node_id_cnt (BetreeListCons - (key, new_msg) l) st in + betree_Node_apply_messages self params node_id_cnt (Betree_List_Cons (key, + new_msg) l) st in let* _ = - betree_node_apply_messages_back self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st in Return (st0, ()) (** [betree_main::betree::Node::{5}::apply]: backward function 0 *) -let betree_node_apply_back - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) : - result (betree_node_t & betree_node_id_counter_t) +let betree_Node_apply_back + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : + result (betree_Node_t & betree_NodeIdCounter_t) = - let l = BetreeListNil in - betree_node_apply_messages_back self params node_id_cnt (BetreeListCons (key, - new_msg) l) st + let l = Betree_List_Nil in + betree_Node_apply_messages_back self params node_id_cnt (Betree_List_Cons + (key, new_msg) l) st (** [betree_main::betree::BeTree::{6}::new]: forward function *) -let betree_be_tree_new_fwd +let betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : - result (state & betree_be_tree_t) + result (state & betree_BeTree_t) = - let* node_id_cnt = betree_node_id_counter_new_fwd in - let* id = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* (st0, _) = betree_store_leaf_node_fwd id BetreeListNil st in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in + let* node_id_cnt = betree_NodeIdCounter_new in + let* id = betree_NodeIdCounter_fresh_id node_id_cnt in + let* (st0, _) = betree_store_leaf_node id Betree_List_Nil st in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in Return (st0, { - betree_be_tree_params = - { - betree_params_min_flush_size = min_flush_size; - betree_params_split_size = split_size - }; - betree_be_tree_node_id_cnt = node_id_cnt0; - betree_be_tree_root = - (BetreeNodeLeaf { betree_leaf_id = id; betree_leaf_size = 0 }) + params = { min_flush_size = min_flush_size; split_size = split_size }; + node_id_cnt = node_id_cnt0; + root = (Betree_Node_Leaf { id = id; size = 0 }) }) (** [betree_main::betree::BeTree::{6}::apply]: forward function *) -let betree_be_tree_apply_fwd - (self : betree_be_tree_t) (key : u64) (msg : betree_message_t) (st : state) : +let betree_BeTree_apply + (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state & unit) = let* (st0, _) = - betree_node_apply_fwd self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in + betree_Node_apply self.root self.params self.node_id_cnt key msg st in let* _ = - betree_node_apply_back self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in + betree_Node_apply_back self.root self.params self.node_id_cnt key msg st in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) -let betree_be_tree_apply_back - (self : betree_be_tree_t) (key : u64) (msg : betree_message_t) (st : state) : - result betree_be_tree_t +let betree_BeTree_apply_back + (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : + result betree_BeTree_t = let* (n, nic) = - betree_node_apply_back self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in - Return - { self with betree_be_tree_node_id_cnt = nic; betree_be_tree_root = n } + betree_Node_apply_back self.root self.params self.node_id_cnt key msg st in + Return { self with node_id_cnt = nic; root = n } (** [betree_main::betree::BeTree::{6}::insert]: forward function *) -let betree_be_tree_insert_fwd - (self : betree_be_tree_t) (key : u64) (value : u64) (st : state) : +let betree_BeTree_insert + (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state & unit) = - let* (st0, _) = - betree_be_tree_apply_fwd self key (BetreeMessageInsert value) st in - let* _ = betree_be_tree_apply_back self key (BetreeMessageInsert value) st in + let* (st0, _) = betree_BeTree_apply self key (Betree_Message_Insert value) st + in + let* _ = betree_BeTree_apply_back self key (Betree_Message_Insert value) st + in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) -let betree_be_tree_insert_back - (self : betree_be_tree_t) (key : u64) (value : u64) (st : state) : - result betree_be_tree_t +let betree_BeTree_insert_back + (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : + result betree_BeTree_t = - betree_be_tree_apply_back self key (BetreeMessageInsert value) st + betree_BeTree_apply_back self key (Betree_Message_Insert value) st (** [betree_main::betree::BeTree::{6}::delete]: forward function *) -let betree_be_tree_delete_fwd - (self : betree_be_tree_t) (key : u64) (st : state) : result (state & unit) = - let* (st0, _) = betree_be_tree_apply_fwd self key BetreeMessageDelete st in - let* _ = betree_be_tree_apply_back self key BetreeMessageDelete st in +let betree_BeTree_delete + (self : betree_BeTree_t) (key : u64) (st : state) : result (state & unit) = + let* (st0, _) = betree_BeTree_apply self key Betree_Message_Delete st in + let* _ = betree_BeTree_apply_back self key Betree_Message_Delete st in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) -let betree_be_tree_delete_back - (self : betree_be_tree_t) (key : u64) (st : state) : - result betree_be_tree_t - = - betree_be_tree_apply_back self key BetreeMessageDelete st +let betree_BeTree_delete_back + (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t = + betree_BeTree_apply_back self key Betree_Message_Delete st (** [betree_main::betree::BeTree::{6}::upsert]: forward function *) -let betree_be_tree_upsert_fwd - (self : betree_be_tree_t) (key : u64) (upd : betree_upsert_fun_state_t) +let betree_BeTree_upsert + (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : result (state & unit) = - let* (st0, _) = - betree_be_tree_apply_fwd self key (BetreeMessageUpsert upd) st in - let* _ = betree_be_tree_apply_back self key (BetreeMessageUpsert upd) st in + let* (st0, _) = betree_BeTree_apply self key (Betree_Message_Upsert upd) st + in + let* _ = betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) -let betree_be_tree_upsert_back - (self : betree_be_tree_t) (key : u64) (upd : betree_upsert_fun_state_t) +let betree_BeTree_upsert_back + (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : - result betree_be_tree_t + result betree_BeTree_t = - betree_be_tree_apply_back self key (BetreeMessageUpsert upd) st + betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st (** [betree_main::betree::BeTree::{6}::lookup]: forward function *) -let betree_be_tree_lookup_fwd - (self : betree_be_tree_t) (key : u64) (st : state) : +let betree_BeTree_lookup + (self : betree_BeTree_t) (key : u64) (st : state) : result (state & (option u64)) = - betree_node_lookup_fwd self.betree_be_tree_root key st + betree_Node_lookup self.root key st (** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) -let betree_be_tree_lookup_back - (self : betree_be_tree_t) (key : u64) (st : state) : - result betree_be_tree_t - = - let* n = betree_node_lookup_back self.betree_be_tree_root key st in - Return { self with betree_be_tree_root = n } +let betree_BeTree_lookup_back + (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t = + let* n = betree_Node_lookup_back self.root key st in + Return { self with root = n } (** [betree_main::main]: forward function *) -let main_fwd : result unit = +let main : result unit = Return () (** Unit test for [betree_main::main] *) -let _ = assert_norm (main_fwd = Return ()) +let _ = assert_norm (main = Return ()) diff --git a/tests/fstar/betree/BetreeMain.Opaque.fsti b/tests/fstar/betree/BetreeMain.Opaque.fsti index c33cf225..c5d0a814 100644 --- a/tests/fstar/betree/BetreeMain.Opaque.fsti +++ b/tests/fstar/betree/BetreeMain.Opaque.fsti @@ -7,24 +7,24 @@ include BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree_utils::load_internal_node]: forward function *) -val betree_utils_load_internal_node_fwd - : u64 -> state -> result (state & (betree_list_t (u64 & betree_message_t))) +val betree_utils_load_internal_node + : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) (** [betree_main::betree_utils::store_internal_node]: forward function *) -val betree_utils_store_internal_node_fwd +val betree_utils_store_internal_node : - u64 -> betree_list_t (u64 & betree_message_t) -> state -> result (state & + u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & unit) (** [betree_main::betree_utils::load_leaf_node]: forward function *) -val betree_utils_load_leaf_node_fwd - : u64 -> state -> result (state & (betree_list_t (u64 & u64))) +val betree_utils_load_leaf_node + : u64 -> state -> result (state & (betree_List_t (u64 & u64))) (** [betree_main::betree_utils::store_leaf_node]: forward function *) -val betree_utils_store_leaf_node_fwd - : u64 -> betree_list_t (u64 & u64) -> state -> result (state & unit) +val betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) (** [core::option::Option::{0}::unwrap]: forward function *) -val core_option_option_unwrap_fwd +val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/betree/BetreeMain.Types.fsti b/tests/fstar/betree/BetreeMain.Types.fsti index a937c726..9320f6b7 100644 --- a/tests/fstar/betree/BetreeMain.Types.fsti +++ b/tests/fstar/betree/BetreeMain.Types.fsti @@ -6,53 +6,47 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree::List] *) -type betree_list_t (t : Type0) = -| BetreeListCons : t -> betree_list_t t -> betree_list_t t -| BetreeListNil : betree_list_t t +type betree_List_t (t : Type0) = +| Betree_List_Cons : t -> betree_List_t t -> betree_List_t t +| Betree_List_Nil : betree_List_t t (** [betree_main::betree::UpsertFunState] *) -type betree_upsert_fun_state_t = -| BetreeUpsertFunStateAdd : u64 -> betree_upsert_fun_state_t -| BetreeUpsertFunStateSub : u64 -> betree_upsert_fun_state_t +type betree_UpsertFunState_t = +| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t +| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t (** [betree_main::betree::Message] *) -type betree_message_t = -| BetreeMessageInsert : u64 -> betree_message_t -| BetreeMessageDelete : betree_message_t -| BetreeMessageUpsert : betree_upsert_fun_state_t -> betree_message_t +type betree_Message_t = +| Betree_Message_Insert : u64 -> betree_Message_t +| Betree_Message_Delete : betree_Message_t +| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t (** [betree_main::betree::Leaf] *) -type betree_leaf_t = { betree_leaf_id : u64; betree_leaf_size : u64; } +type betree_Leaf_t = { id : u64; size : u64; } (** [betree_main::betree::Internal] *) -type betree_internal_t = +type betree_Internal_t = { - betree_internal_id : u64; - betree_internal_pivot : u64; - betree_internal_left : betree_node_t; - betree_internal_right : betree_node_t; + id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; } (** [betree_main::betree::Node] *) -and betree_node_t = -| BetreeNodeInternal : betree_internal_t -> betree_node_t -| BetreeNodeLeaf : betree_leaf_t -> betree_node_t +and betree_Node_t = +| Betree_Node_Internal : betree_Internal_t -> betree_Node_t +| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t (** [betree_main::betree::Params] *) -type betree_params_t = -{ - betree_params_min_flush_size : u64; betree_params_split_size : u64; -} +type betree_Params_t = { min_flush_size : u64; split_size : u64; } (** [betree_main::betree::NodeIdCounter] *) -type betree_node_id_counter_t = { betree_node_id_counter_next_node_id : u64; } +type betree_NodeIdCounter_t = { next_node_id : u64; } (** [betree_main::betree::BeTree] *) -type betree_be_tree_t = +type betree_BeTree_t = { - betree_be_tree_params : betree_params_t; - betree_be_tree_node_id_cnt : betree_node_id_counter_t; - betree_be_tree_root : betree_node_t; + params : betree_Params_t; + node_id_cnt : betree_NodeIdCounter_t; + root : betree_Node_t; } (** The state type used in the state-error monad *) diff --git a/tests/fstar/betree/Primitives.fst b/tests/fstar/betree/Primitives.fst index 9db82069..3297803c 100644 --- a/tests/fstar/betree/Primitives.fst +++ b/tests/fstar/betree/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -169,17 +187,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize @@ -231,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -259,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -278,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -295,55 +389,54 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -358,18 +451,279 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst index 823df03a..8722f0bf 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst @@ -8,95 +8,95 @@ open BetreeMain.Types (** [betree_main::betree::List::{1}::len]: decreases clause *) unfold -let betree_list_len_decreases (t : Type0) (self : betree_list_t t) : nat = +let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : nat = admit () (** [betree_main::betree::List::{1}::split_at]: decreases clause *) unfold -let betree_list_split_at_decreases (t : Type0) (self : betree_list_t t) +let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = admit () (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_list_partition_at_pivot_decreases (t : Type0) - (self : betree_list_t (u64 & t)) (pivot : u64) : nat = +let betree_List_partition_at_pivot_decreases (t : Type0) + (self : betree_List_t (u64 & t)) (pivot : u64) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) unfold -let betree_node_lookup_first_message_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_lookup_first_message_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) unfold -let betree_node_apply_upserts_decreases - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let betree_Node_apply_upserts_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) unfold -let betree_node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : nat = +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = admit () (** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) unfold -let betree_internal_lookup_in_children_decreases (self : betree_internal_t) +let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::lookup]: decreases clause *) unfold -let betree_node_lookup_decreases (self : betree_node_t) (key : u64) +let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) unfold -let betree_node_filter_messages_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_filter_messages_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) unfold -let betree_node_lookup_first_message_after_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_lookup_first_message_after_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: decreases clause *) unfold -let betree_node_apply_messages_to_internal_decreases - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_apply_messages_to_internal_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) unfold -let betree_node_lookup_mut_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : nat = +let betree_Node_lookup_mut_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: decreases clause *) unfold -let betree_node_apply_messages_to_leaf_decreases - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_apply_messages_to_leaf_decreases + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Internal::{4}::flush]: decreases clause *) unfold -let betree_internal_flush_decreases (self : betree_internal_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat = +let betree_Internal_flush_decreases (self : betree_Internal_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) unfold -let betree_node_apply_messages_decreases (self : betree_node_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat = +let betree_Node_apply_messages_decreases (self : betree_Node_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst index 07484711..cda7b920 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst @@ -8,8 +8,8 @@ open BetreeMain.Types (*** Well-founded relations *) (* We had a few issues when proving termination of the mutually recursive functions: - * - betree_internal_flush - * - betree_node_apply_messages + * - betree_Internal_flush + * - betree_Node_apply_messages * * The quantity which effectively decreases is: * (betree_size, messages_length) @@ -103,108 +103,108 @@ let wf_nat_pair_lem (p0 p1 : nat_pair) : (** [betree_main::betree::List::{1}::len]: decreases clause *) unfold -let betree_list_len_decreases (t : Type0) (self : betree_list_t t) : betree_list_t t = +let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : betree_List_t t = self (** [betree_main::betree::List::{1}::split_at]: decreases clause *) unfold -let betree_list_split_at_decreases (t : Type0) (self : betree_list_t t) +let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = n (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_list_partition_at_pivot_decreases (t : Type0) - (self : betree_list_t (u64 & t)) (pivot : u64) : betree_list_t (u64 & t) = +let betree_List_partition_at_pivot_decreases (t : Type0) + (self : betree_List_t (u64 & t)) (pivot : u64) : betree_List_t (u64 & t) = self (** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) unfold -let betree_node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : betree_list_t (u64 & u64) = +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : betree_List_t (u64 & u64) = bindings (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) unfold -let betree_node_lookup_first_message_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_lookup_first_message_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) unfold -let betree_node_apply_upserts_decreases - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) - (key : u64) (st : state) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_upserts_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) + (key : u64) (st : state) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) unfold -let betree_internal_lookup_in_children_decreases (self : betree_internal_t) - (key : u64) (st : state) : betree_internal_t = +let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) + (key : u64) (st : state) : betree_Internal_t = self (** [betree_main::betree::Node::{5}::lookup]: decreases clause *) unfold -let betree_node_lookup_decreases (self : betree_node_t) (key : u64) - (st : state) : betree_node_t = +let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) + (st : state) : betree_Node_t = self (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) unfold -let betree_node_lookup_mut_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : betree_list_t (u64 & u64) = +let betree_Node_lookup_mut_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : betree_List_t (u64 & u64) = bindings unfold -let betree_node_apply_messages_to_leaf_decreases - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_messages_to_leaf_decreases + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = new_msgs (** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) unfold -let betree_node_filter_messages_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_filter_messages_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) unfold -let betree_node_lookup_first_message_after_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_lookup_first_message_after_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs -let betree_node_apply_messages_to_internal_decreases - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_messages_to_internal_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = new_msgs (*** Decrease clauses - nat_pair *) /// The following decrease clauses use the [nat_pair] definition and the well-founded /// relation proven above. -let rec betree_size (bt : betree_node_t) : nat = +let rec betree_size (bt : betree_Node_t) : nat = match bt with - | BetreeNodeInternal node -> 1 + betree_internal_size node - | BetreeNodeLeaf _ -> 1 + | Betree_Node_Internal node -> 1 + betree_Internal_size node + | Betree_Node_Leaf _ -> 1 -and betree_internal_size (node : betree_internal_t) : nat = - 1 + betree_size node.betree_internal_left + betree_size node.betree_internal_right +and betree_Internal_size (node : betree_Internal_t) : nat = + 1 + betree_size node.left + betree_size node.right -let rec betree_list_len (#a : Type0) (ls : betree_list_t a) : nat = +let rec betree_List_len (#a : Type0) (ls : betree_List_t a) : nat = match ls with - | BetreeListCons _ tl -> 1 + betree_list_len tl - | BetreeListNil -> 0 + | Betree_List_Cons _ tl -> 1 + betree_List_len tl + | Betree_List_Nil -> 0 (** [betree_main::betree::Internal::{4}::flush]: decreases clause *) unfold -let betree_internal_flush_decreases (self : betree_internal_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat_pair = - (|betree_internal_size self, 0|) +let betree_Internal_flush_decreases (self : betree_Internal_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat_pair = + (|betree_Internal_size self, 0|) (** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) unfold -let betree_node_apply_messages_decreases (self : betree_node_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat_pair = - (|betree_size self, betree_list_len msgs|) +let betree_Node_apply_messages_decreases (self : betree_Node_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : nat_pair = + (|betree_size self, betree_List_len msgs|) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst index 3d08cd3c..08c4f615 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst @@ -9,35 +9,35 @@ include BetreeMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree::load_internal_node]: forward function *) -let betree_load_internal_node_fwd +let betree_load_internal_node (id : u64) (st : state) : - result (state & (betree_list_t (u64 & betree_message_t))) + result (state & (betree_List_t (u64 & betree_Message_t))) = - betree_utils_load_internal_node_fwd id st + betree_utils_load_internal_node id st (** [betree_main::betree::store_internal_node]: forward function *) -let betree_store_internal_node_fwd - (id : u64) (content : betree_list_t (u64 & betree_message_t)) (st : state) : +let betree_store_internal_node + (id : u64) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : result (state & unit) = - let* (st0, _) = betree_utils_store_internal_node_fwd id content st in + let* (st0, _) = betree_utils_store_internal_node id content st in Return (st0, ()) (** [betree_main::betree::load_leaf_node]: forward function *) -let betree_load_leaf_node_fwd - (id : u64) (st : state) : result (state & (betree_list_t (u64 & u64))) = - betree_utils_load_leaf_node_fwd id st +let betree_load_leaf_node + (id : u64) (st : state) : result (state & (betree_List_t (u64 & u64))) = + betree_utils_load_leaf_node id st (** [betree_main::betree::store_leaf_node]: forward function *) -let betree_store_leaf_node_fwd - (id : u64) (content : betree_list_t (u64 & u64)) (st : state) : +let betree_store_leaf_node + (id : u64) (content : betree_List_t (u64 & u64)) (st : state) : result (state & unit) = - let* (st0, _) = betree_utils_store_leaf_node_fwd id content st in + let* (st0, _) = betree_utils_store_leaf_node id content st in Return (st0, ()) (** [betree_main::betree::fresh_node_id]: forward function *) -let betree_fresh_node_id_fwd (counter : u64) : result u64 = +let betree_fresh_node_id (counter : u64) : result u64 = let* _ = u64_add counter 1 in Return counter (** [betree_main::betree::fresh_node_id]: backward function 0 *) @@ -45,1208 +45,1123 @@ let betree_fresh_node_id_back (counter : u64) : result u64 = u64_add counter 1 (** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) -let betree_node_id_counter_new_fwd : result betree_node_id_counter_t = - Return { betree_node_id_counter_next_node_id = 0 } +let betree_NodeIdCounter_new : result betree_NodeIdCounter_t = + Return { next_node_id = 0 } (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) -let betree_node_id_counter_fresh_id_fwd - (self : betree_node_id_counter_t) : result u64 = - let* _ = u64_add self.betree_node_id_counter_next_node_id 1 in - Return self.betree_node_id_counter_next_node_id +let betree_NodeIdCounter_fresh_id + (self : betree_NodeIdCounter_t) : result u64 = + let* _ = u64_add self.next_node_id 1 in Return self.next_node_id (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) -let betree_node_id_counter_fresh_id_back - (self : betree_node_id_counter_t) : result betree_node_id_counter_t = - let* i = u64_add self.betree_node_id_counter_next_node_id 1 in - Return { betree_node_id_counter_next_node_id = i } - -(** [core::num::u64::{9}::MAX] *) -let core_num_u64_max_body : result u64 = Return 18446744073709551615 -let core_num_u64_max_c : u64 = eval_global core_num_u64_max_body +let betree_NodeIdCounter_fresh_id_back + (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t = + let* i = u64_add self.next_node_id 1 in Return { next_node_id = i } (** [betree_main::betree::upsert_update]: forward function *) -let betree_upsert_update_fwd - (prev : option u64) (st : betree_upsert_fun_state_t) : result u64 = +let betree_upsert_update + (prev : option u64) (st : betree_UpsertFunState_t) : result u64 = begin match prev with | None -> begin match st with - | BetreeUpsertFunStateAdd v -> Return v - | BetreeUpsertFunStateSub i -> Return 0 + | Betree_UpsertFunState_Add v -> Return v + | Betree_UpsertFunState_Sub i -> Return 0 end | Some prev0 -> begin match st with - | BetreeUpsertFunStateAdd v -> - let* margin = u64_sub core_num_u64_max_c prev0 in - if margin >= v then u64_add prev0 v else Return core_num_u64_max_c - | BetreeUpsertFunStateSub v -> + | Betree_UpsertFunState_Add v -> + let* margin = u64_sub core_u64_max prev0 in + if margin >= v then u64_add prev0 v else Return core_u64_max + | Betree_UpsertFunState_Sub v -> if prev0 >= v then u64_sub prev0 v else Return 0 end end (** [betree_main::betree::List::{1}::len]: forward function *) -let rec betree_list_len_fwd - (t : Type0) (self : betree_list_t t) : - Tot (result u64) (decreases (betree_list_len_decreases t self)) +let rec betree_List_len + (t : Type0) (self : betree_List_t t) : + Tot (result u64) (decreases (betree_List_len_decreases t self)) = begin match self with - | BetreeListCons x tl -> let* i = betree_list_len_fwd t tl in u64_add 1 i - | BetreeListNil -> Return 0 + | Betree_List_Cons x tl -> let* i = betree_List_len t tl in u64_add 1 i + | Betree_List_Nil -> Return 0 end (** [betree_main::betree::List::{1}::split_at]: forward function *) -let rec betree_list_split_at_fwd - (t : Type0) (self : betree_list_t t) (n : u64) : - Tot (result ((betree_list_t t) & (betree_list_t t))) - (decreases (betree_list_split_at_decreases t self n)) +let rec betree_List_split_at + (t : Type0) (self : betree_List_t t) (n : u64) : + Tot (result ((betree_List_t t) & (betree_List_t t))) + (decreases (betree_List_split_at_decreases t self n)) = if n = 0 - then Return (BetreeListNil, self) + then Return (Betree_List_Nil, self) else begin match self with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let* i = u64_sub n 1 in - let* p = betree_list_split_at_fwd t tl i in + let* p = betree_List_split_at t tl i in let (ls0, ls1) = p in let l = ls0 in - Return (BetreeListCons hd l, ls1) - | BetreeListNil -> Fail Failure + Return (Betree_List_Cons hd l, ls1) + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_list_push_front_fwd_back - (t : Type0) (self : betree_list_t t) (x : t) : result (betree_list_t t) = - let tl = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_push_front + (t : Type0) (self : betree_List_t t) (x : t) : result (betree_List_t t) = + let tl = core_mem_replace (betree_List_t t) self Betree_List_Nil in let l = tl in - Return (BetreeListCons x l) + Return (Betree_List_Cons x l) (** [betree_main::betree::List::{1}::pop_front]: forward function *) -let betree_list_pop_front_fwd (t : Type0) (self : betree_list_t t) : result t = - let ls = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = + let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with - | BetreeListCons x tl -> Return x - | BetreeListNil -> Fail Failure + | Betree_List_Cons x tl -> Return x + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) -let betree_list_pop_front_back - (t : Type0) (self : betree_list_t t) : result (betree_list_t t) = - let ls = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_pop_front_back + (t : Type0) (self : betree_List_t t) : result (betree_List_t t) = + let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with - | BetreeListCons x tl -> Return tl - | BetreeListNil -> Fail Failure + | Betree_List_Cons x tl -> Return tl + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::hd]: forward function *) -let betree_list_hd_fwd (t : Type0) (self : betree_list_t t) : result t = +let betree_List_hd (t : Type0) (self : betree_List_t t) : result t = begin match self with - | BetreeListCons hd l -> Return hd - | BetreeListNil -> Fail Failure + | Betree_List_Cons hd l -> Return hd + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{2}::head_has_key]: forward function *) -let betree_list_head_has_key_fwd - (t : Type0) (self : betree_list_t (u64 & t)) (key : u64) : result bool = +let betree_List_head_has_key + (t : Type0) (self : betree_List_t (u64 & t)) (key : u64) : result bool = begin match self with - | BetreeListCons hd l -> let (i, _) = hd in Return (i = key) - | BetreeListNil -> Return false + | Betree_List_Cons hd l -> let (i, _) = hd in Return (i = key) + | Betree_List_Nil -> Return false end (** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -let rec betree_list_partition_at_pivot_fwd - (t : Type0) (self : betree_list_t (u64 & t)) (pivot : u64) : - Tot (result ((betree_list_t (u64 & t)) & (betree_list_t (u64 & t)))) - (decreases (betree_list_partition_at_pivot_decreases t self pivot)) +let rec betree_List_partition_at_pivot + (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : + Tot (result ((betree_List_t (u64 & t)) & (betree_List_t (u64 & t)))) + (decreases (betree_List_partition_at_pivot_decreases t self pivot)) = begin match self with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, x) = hd in if i >= pivot - then Return (BetreeListNil, BetreeListCons (i, x) tl) + then Return (Betree_List_Nil, Betree_List_Cons (i, x) tl) else - let* p = betree_list_partition_at_pivot_fwd t tl pivot in + let* p = betree_List_partition_at_pivot t tl pivot in let (ls0, ls1) = p in let l = ls0 in - Return (BetreeListCons (i, x) l, ls1) - | BetreeListNil -> Return (BetreeListNil, BetreeListNil) + Return (Betree_List_Cons (i, x) l, ls1) + | Betree_List_Nil -> Return (Betree_List_Nil, Betree_List_Nil) end (** [betree_main::betree::Leaf::{3}::split]: forward function *) -let betree_leaf_split_fwd - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result (state & betree_internal_t) + result (state & betree_Internal_t) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* p0 = betree_list_hd_fwd (u64 & u64) content1 in + let* p0 = betree_List_hd (u64 & u64) content1 in let (pivot, _) = p0 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st0, _) = betree_store_leaf_node_fwd id0 content0 st in - let* (st1, _) = betree_store_leaf_node_fwd id1 content1 st0 in - let n = BetreeNodeLeaf - { betree_leaf_id = id0; betree_leaf_size = params.betree_params_split_size - } in - let n0 = BetreeNodeLeaf - { betree_leaf_id = id1; betree_leaf_size = params.betree_params_split_size - } in - Return (st1, - { - betree_internal_id = self.betree_leaf_id; - betree_internal_pivot = pivot; - betree_internal_left = n; - betree_internal_right = n0 - }) + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st0, _) = betree_store_leaf_node id0 content0 st in + let* (st1, _) = betree_store_leaf_node id1 content1 st0 in + let n = Betree_Node_Leaf { id = id0; size = params.split_size } in + let n0 = Betree_Node_Leaf { id = id1; size = params.split_size } in + Return (st1, { id = self.id; pivot = pivot; left = n; right = n0 }) (** [betree_main::betree::Leaf::{3}::split]: backward function 0 *) -let betree_leaf_split_back0 - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split_back0 + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) (st0 : state) : result (state & unit) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* _ = betree_list_hd_fwd (u64 & u64) content1 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st1, _) = betree_store_leaf_node_fwd id0 content0 st in - let* _ = betree_store_leaf_node_fwd id1 content1 st1 in + let* _ = betree_List_hd (u64 & u64) content1 in + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st1, _) = betree_store_leaf_node id0 content0 st in + let* _ = betree_store_leaf_node id1 content1 st1 in Return (st0, ()) (** [betree_main::betree::Leaf::{3}::split]: backward function 1 *) -let betree_leaf_split_back1 - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split_back1 + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) (st0 : state) : result (state & unit) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* _ = betree_list_hd_fwd (u64 & u64) content1 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st1, _) = betree_store_leaf_node_fwd id0 content0 st in - let* _ = betree_store_leaf_node_fwd id1 content1 st1 in + let* _ = betree_List_hd (u64 & u64) content1 in + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st1, _) = betree_store_leaf_node id0 content0 st in + let* _ = betree_store_leaf_node id1 content1 st1 in Return (st0, ()) (** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) -let betree_leaf_split_back2 - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split_back2 + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) (st0 : state) : - result (state & betree_node_id_counter_t) + result (state & betree_NodeIdCounter_t) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* _ = betree_list_hd_fwd (u64 & u64) content1 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st1, _) = betree_store_leaf_node_fwd id0 content0 st in - let* _ = betree_store_leaf_node_fwd id1 content1 st1 in - let* node_id_cnt1 = betree_node_id_counter_fresh_id_back node_id_cnt0 in + let* _ = betree_List_hd (u64 & u64) content1 in + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st1, _) = betree_store_leaf_node id0 content0 st in + let* _ = betree_store_leaf_node id1 content1 st1 in + let* node_id_cnt1 = betree_NodeIdCounter_fresh_id_back node_id_cnt0 in Return (st0, node_id_cnt1) (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) -let rec betree_node_lookup_first_message_for_key_fwd - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_for_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_for_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons x next_msgs -> + | Betree_List_Cons x next_msgs -> let (i, m) = x in if i >= key - then Return (BetreeListCons (i, m) next_msgs) - else betree_node_lookup_first_message_for_key_fwd key next_msgs - | BetreeListNil -> Return BetreeListNil + then Return (Betree_List_Cons (i, m) next_msgs) + else betree_Node_lookup_first_message_for_key key next_msgs + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) -let rec betree_node_lookup_first_message_for_key_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) - (ret : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_for_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_for_key_back + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) + (ret : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons x next_msgs -> + | Betree_List_Cons x next_msgs -> let (i, m) = x in if i >= key then Return ret else let* next_msgs0 = - betree_node_lookup_first_message_for_key_back key next_msgs ret in - Return (BetreeListCons (i, m) next_msgs0) - | BetreeListNil -> Return ret + betree_Node_lookup_first_message_for_key_back key next_msgs ret in + Return (Betree_List_Cons (i, m) next_msgs0) + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) -let rec betree_node_apply_upserts_fwd - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let rec betree_Node_apply_upserts + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : Tot (result (state & u64)) - (decreases (betree_node_apply_upserts_decreases msgs prev key st)) + (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_list_head_has_key_fwd betree_message_t msgs key in + let* b = betree_List_head_has_key betree_Message_t msgs key in if b then - let* msg = betree_list_pop_front_fwd (u64 & betree_message_t) msgs in + let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in let (_, m) = msg in begin match m with - | BetreeMessageInsert i -> Fail Failure - | BetreeMessageDelete -> Fail Failure - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd prev s in - let* msgs0 = betree_list_pop_front_back (u64 & betree_message_t) msgs in - betree_node_apply_upserts_fwd msgs0 (Some v) key st + | Betree_Message_Insert i -> Fail Failure + | Betree_Message_Delete -> Fail Failure + | Betree_Message_Upsert s -> + let* v = betree_upsert_update prev s in + let* msgs0 = betree_List_pop_front_back (u64 & betree_Message_t) msgs in + betree_Node_apply_upserts msgs0 (Some v) key st end else - let* (st0, v) = core_option_option_unwrap_fwd u64 prev st in + let* (st0, v) = core_option_Option_unwrap u64 prev st in let* _ = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs (key, - BetreeMessageInsert v) in + betree_List_push_front (u64 & betree_Message_t) msgs (key, + Betree_Message_Insert v) in Return (st0, v) (** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) -let rec betree_node_apply_upserts_back - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let rec betree_Node_apply_upserts_back + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) (st0 : state) : - Tot (result (state & (betree_list_t (u64 & betree_message_t)))) - (decreases (betree_node_apply_upserts_decreases msgs prev key st)) + Tot (result (state & (betree_List_t (u64 & betree_Message_t)))) + (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_list_head_has_key_fwd betree_message_t msgs key in + let* b = betree_List_head_has_key betree_Message_t msgs key in if b then - let* msg = betree_list_pop_front_fwd (u64 & betree_message_t) msgs in + let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in let (_, m) = msg in begin match m with - | BetreeMessageInsert i -> Fail Failure - | BetreeMessageDelete -> Fail Failure - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd prev s in - let* msgs0 = betree_list_pop_front_back (u64 & betree_message_t) msgs in - betree_node_apply_upserts_back msgs0 (Some v) key st st0 + | Betree_Message_Insert i -> Fail Failure + | Betree_Message_Delete -> Fail Failure + | Betree_Message_Upsert s -> + let* v = betree_upsert_update prev s in + let* msgs0 = betree_List_pop_front_back (u64 & betree_Message_t) msgs in + betree_Node_apply_upserts_back msgs0 (Some v) key st st0 end else - let* (_, v) = core_option_option_unwrap_fwd u64 prev st in + let* (_, v) = core_option_Option_unwrap u64 prev st in let* msgs0 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs (key, - BetreeMessageInsert v) in + betree_List_push_front (u64 & betree_Message_t) msgs (key, + Betree_Message_Insert v) in Return (st0, msgs0) (** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) -let rec betree_node_lookup_in_bindings_fwd - (key : u64) (bindings : betree_list_t (u64 & u64)) : +let rec betree_Node_lookup_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (option u64)) - (decreases (betree_node_lookup_in_bindings_decreases key bindings)) + (decreases (betree_Node_lookup_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i = key then Return (Some i0) - else - if i > key - then Return None - else betree_node_lookup_in_bindings_fwd key tl - | BetreeListNil -> Return None + else if i > key then Return None else betree_Node_lookup_in_bindings key tl + | Betree_List_Nil -> Return None end (** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) -let rec betree_internal_lookup_in_children_fwd - (self : betree_internal_t) (key : u64) (st : state) : +let rec betree_Internal_lookup_in_children + (self : betree_Internal_t) (key : u64) (st : state) : Tot (result (state & (option u64))) - (decreases (betree_internal_lookup_in_children_decreases self key st)) + (decreases (betree_Internal_lookup_in_children_decreases self key st)) = - if key < self.betree_internal_pivot - then betree_node_lookup_fwd self.betree_internal_left key st - else betree_node_lookup_fwd self.betree_internal_right key st + if key < self.pivot + then betree_Node_lookup self.left key st + else betree_Node_lookup self.right key st (** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) -and betree_internal_lookup_in_children_back - (self : betree_internal_t) (key : u64) (st : state) (st0 : state) : - Tot (result (state & betree_internal_t)) - (decreases (betree_internal_lookup_in_children_decreases self key st)) +and betree_Internal_lookup_in_children_back + (self : betree_Internal_t) (key : u64) (st : state) (st0 : state) : + Tot (result (state & betree_Internal_t)) + (decreases (betree_Internal_lookup_in_children_decreases self key st)) = - if key < self.betree_internal_pivot + if key < self.pivot then - let* (st1, n) = - betree_node_lookup_back self.betree_internal_left key st st0 in - Return (st1, { self with betree_internal_left = n }) + let* (st1, n) = betree_Node_lookup_back self.left key st st0 in + Return (st1, { self with left = n }) else - let* (st1, n) = - betree_node_lookup_back self.betree_internal_right key st st0 in - Return (st1, { self with betree_internal_right = n }) + let* (st1, n) = betree_Node_lookup_back self.right key st st0 in + Return (st1, { self with right = n }) (** [betree_main::betree::Node::{5}::lookup]: forward function *) -and betree_node_lookup_fwd - (self : betree_node_t) (key : u64) (st : state) : +and betree_Node_lookup + (self : betree_Node_t) (key : u64) (st : state) : Tot (result (state & (option u64))) - (decreases (betree_node_lookup_decreases self key st)) + (decreases (betree_Node_lookup_decreases self key st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, msgs) = betree_load_internal_node_fwd node.betree_internal_id st - in - let* pending = betree_node_lookup_first_message_for_key_fwd key msgs in + | Betree_Node_Internal node -> + let* (st0, msgs) = betree_load_internal_node node.id st in + let* pending = betree_Node_lookup_first_message_for_key key msgs in begin match pending with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, msg) = p in if k <> key then - let* (st1, opt) = betree_internal_lookup_in_children_fwd node key st0 - in + let* (st1, o) = betree_Internal_lookup_in_children node key st0 in let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, msg) l) in - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, msg) l) in + Return (st1, o) else begin match msg with - | BetreeMessageInsert v -> + | Betree_Message_Insert v -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageInsert v) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l) in Return (st0, Some v) - | BetreeMessageDelete -> + | Betree_Message_Delete -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageDelete) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l) in Return (st0, None) - | BetreeMessageUpsert ufs -> - let* (st1, v) = betree_internal_lookup_in_children_fwd node key st0 - in + | Betree_Message_Upsert ufs -> + let* (st1, v) = betree_Internal_lookup_in_children node key st0 in let* (st2, v0) = - betree_node_apply_upserts_fwd (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in + betree_Node_apply_upserts (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in let* (st3, node0) = - betree_internal_lookup_in_children_back node key st0 st2 in + betree_Internal_lookup_in_children_back node key st0 st2 in let* (st4, pending0) = - betree_node_apply_upserts_back (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 st3 in + betree_Node_apply_upserts_back (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 st3 in let* msgs0 = - betree_node_lookup_first_message_for_key_back key msgs pending0 in - let* (st5, _) = - betree_store_internal_node_fwd node0.betree_internal_id msgs0 st4 - in + betree_Node_lookup_first_message_for_key_back key msgs pending0 in + let* (st5, _) = betree_store_internal_node node0.id msgs0 st4 in Return (st5, Some v0) end - | BetreeListNil -> - let* (st1, opt) = betree_internal_lookup_in_children_fwd node key st0 in + | Betree_List_Nil -> + let* (st1, o) = betree_Internal_lookup_in_children node key st0 in let* _ = - betree_node_lookup_first_message_for_key_back key msgs BetreeListNil in - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back key msgs Betree_List_Nil + in + Return (st1, o) end - | BetreeNodeLeaf node -> - let* (st0, bindings) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* opt = betree_node_lookup_in_bindings_fwd key bindings in - Return (st0, opt) + | Betree_Node_Leaf node -> + let* (st0, bindings) = betree_load_leaf_node node.id st in + let* o = betree_Node_lookup_in_bindings key bindings in + Return (st0, o) end (** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) -and betree_node_lookup_back - (self : betree_node_t) (key : u64) (st : state) (st0 : state) : - Tot (result (state & betree_node_t)) - (decreases (betree_node_lookup_decreases self key st)) +and betree_Node_lookup_back + (self : betree_Node_t) (key : u64) (st : state) (st0 : state) : + Tot (result (state & betree_Node_t)) + (decreases (betree_Node_lookup_decreases self key st)) = begin match self with - | BetreeNodeInternal node -> - let* (st1, msgs) = betree_load_internal_node_fwd node.betree_internal_id st - in - let* pending = betree_node_lookup_first_message_for_key_fwd key msgs in + | Betree_Node_Internal node -> + let* (st1, msgs) = betree_load_internal_node node.id st in + let* pending = betree_Node_lookup_first_message_for_key key msgs in begin match pending with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, msg) = p in if k <> key then let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, msg) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, msg) l) in let* (st2, node0) = - betree_internal_lookup_in_children_back node key st1 st0 in - Return (st2, BetreeNodeInternal node0) + betree_Internal_lookup_in_children_back node key st1 st0 in + Return (st2, Betree_Node_Internal node0) else begin match msg with - | BetreeMessageInsert v -> + | Betree_Message_Insert v -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageInsert v) l) in - Return (st0, BetreeNodeInternal node) - | BetreeMessageDelete -> + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l) in + Return (st0, Betree_Node_Internal node) + | Betree_Message_Delete -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageDelete) l) in - Return (st0, BetreeNodeInternal node) - | BetreeMessageUpsert ufs -> - let* (st2, v) = betree_internal_lookup_in_children_fwd node key st1 - in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l) in + Return (st0, Betree_Node_Internal node) + | Betree_Message_Upsert ufs -> + let* (st2, v) = betree_Internal_lookup_in_children node key st1 in let* (st3, _) = - betree_node_apply_upserts_fwd (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st2 in + betree_Node_apply_upserts (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st2 in let* (st4, node0) = - betree_internal_lookup_in_children_back node key st1 st3 in + betree_Internal_lookup_in_children_back node key st1 st3 in let* (st5, pending0) = - betree_node_apply_upserts_back (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st2 st4 in + betree_Node_apply_upserts_back (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st2 st4 in let* msgs0 = - betree_node_lookup_first_message_for_key_back key msgs pending0 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id msgs0 st5 - in - Return (st0, BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back key msgs pending0 in + let* _ = betree_store_internal_node node0.id msgs0 st5 in + Return (st0, Betree_Node_Internal node0) end - | BetreeListNil -> + | Betree_List_Nil -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs BetreeListNil in + betree_Node_lookup_first_message_for_key_back key msgs Betree_List_Nil + in let* (st2, node0) = - betree_internal_lookup_in_children_back node key st1 st0 in - Return (st2, BetreeNodeInternal node0) + betree_Internal_lookup_in_children_back node key st1 st0 in + Return (st2, Betree_Node_Internal node0) end - | BetreeNodeLeaf node -> - let* (_, bindings) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* _ = betree_node_lookup_in_bindings_fwd key bindings in - Return (st0, BetreeNodeLeaf node) + | Betree_Node_Leaf node -> + let* (_, bindings) = betree_load_leaf_node node.id st in + let* _ = betree_Node_lookup_in_bindings key bindings in + Return (st0, Betree_Node_Leaf node) end (** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_filter_messages_for_key_fwd_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_filter_messages_for_key_decreases key msgs)) +let rec betree_Node_filter_messages_for_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_filter_messages_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, m) = p in if k = key then let* msgs0 = - betree_list_pop_front_back (u64 & betree_message_t) (BetreeListCons (k, - m) l) in - betree_node_filter_messages_for_key_fwd_back key msgs0 - else Return (BetreeListCons (k, m) l) - | BetreeListNil -> Return BetreeListNil + betree_List_pop_front_back (u64 & betree_Message_t) (Betree_List_Cons + (k, m) l) in + betree_Node_filter_messages_for_key key msgs0 + else Return (Betree_List_Cons (k, m) l) + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) -let rec betree_node_lookup_first_message_after_key_fwd - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_after_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_after_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_after_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p next_msgs -> + | Betree_List_Cons p next_msgs -> let (k, m) = p in if k = key - then betree_node_lookup_first_message_after_key_fwd key next_msgs - else Return (BetreeListCons (k, m) next_msgs) - | BetreeListNil -> Return BetreeListNil + then betree_Node_lookup_first_message_after_key key next_msgs + else Return (Betree_List_Cons (k, m) next_msgs) + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) -let rec betree_node_lookup_first_message_after_key_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) - (ret : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_after_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_after_key_back + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) + (ret : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_after_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p next_msgs -> + | Betree_List_Cons p next_msgs -> let (k, m) = p in if k = key then let* next_msgs0 = - betree_node_lookup_first_message_after_key_back key next_msgs ret in - Return (BetreeListCons (k, m) next_msgs0) + betree_Node_lookup_first_message_after_key_back key next_msgs ret in + Return (Betree_List_Cons (k, m) next_msgs0) else Return ret - | BetreeListNil -> Return ret + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_node_apply_to_internal_fwd_back - (msgs : betree_list_t (u64 & betree_message_t)) (key : u64) - (new_msg : betree_message_t) : - result (betree_list_t (u64 & betree_message_t)) +let betree_Node_apply_to_internal + (msgs : betree_List_t (u64 & betree_Message_t)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 & betree_Message_t)) = - let* msgs0 = betree_node_lookup_first_message_for_key_fwd key msgs in - let* b = betree_list_head_has_key_fwd betree_message_t msgs0 key in + let* msgs0 = betree_Node_lookup_first_message_for_key key msgs in + let* b = betree_List_head_has_key betree_Message_t msgs0 key in if b then begin match new_msg with - | BetreeMessageInsert i -> - let* msgs1 = betree_node_filter_messages_for_key_fwd_back key msgs0 in + | Betree_Message_Insert i -> + let* msgs1 = betree_Node_filter_messages_for_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert i) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageDelete -> - let* msgs1 = betree_node_filter_messages_for_key_fwd_back key msgs0 in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert i) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Delete -> + let* msgs1 = betree_Node_filter_messages_for_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageDelete) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageUpsert s -> - let* p = betree_list_hd_fwd (u64 & betree_message_t) msgs0 in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Delete) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Upsert s -> + let* p = betree_List_hd (u64 & betree_Message_t) msgs0 in let (_, m) = p in begin match m with - | BetreeMessageInsert prev -> - let* v = betree_upsert_update_fwd (Some prev) s in - let* msgs1 = betree_list_pop_front_back (u64 & betree_message_t) msgs0 + | Betree_Message_Insert prev -> + let* v = betree_upsert_update (Some prev) s in + let* msgs1 = betree_List_pop_front_back (u64 & betree_Message_t) msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert v) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageDelete -> - let* v = betree_upsert_update_fwd None s in - let* msgs1 = betree_list_pop_front_back (u64 & betree_message_t) msgs0 + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert v) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Delete -> + let* v = betree_upsert_update None s in + let* msgs1 = betree_List_pop_front_back (u64 & betree_Message_t) msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert v) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageUpsert ufs -> - let* msgs1 = betree_node_lookup_first_message_after_key_fwd key msgs0 - in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert v) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Upsert ufs -> + let* msgs1 = betree_Node_lookup_first_message_after_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageUpsert s) in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Upsert s) in let* msgs3 = - betree_node_lookup_first_message_after_key_back key msgs0 msgs2 in - betree_node_lookup_first_message_for_key_back key msgs msgs3 + betree_Node_lookup_first_message_after_key_back key msgs0 msgs2 in + betree_Node_lookup_first_message_for_key_back key msgs msgs3 end end else let* msgs1 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs0 (key, - new_msg) in - betree_node_lookup_first_message_for_key_back key msgs msgs1 + betree_List_push_front (u64 & betree_Message_t) msgs0 (key, new_msg) in + betree_Node_lookup_first_message_for_key_back key msgs msgs1 (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_apply_messages_to_internal_fwd_back - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_apply_messages_to_internal_decreases msgs new_msgs)) +let rec betree_Node_apply_messages_to_internal + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_apply_messages_to_internal_decreases msgs new_msgs)) = begin match new_msgs with - | BetreeListCons new_msg new_msgs_tl -> + | Betree_List_Cons new_msg new_msgs_tl -> let (i, m) = new_msg in - let* msgs0 = betree_node_apply_to_internal_fwd_back msgs i m in - betree_node_apply_messages_to_internal_fwd_back msgs0 new_msgs_tl - | BetreeListNil -> Return msgs + let* msgs0 = betree_Node_apply_to_internal msgs i m in + betree_Node_apply_messages_to_internal msgs0 new_msgs_tl + | Betree_List_Nil -> Return msgs end (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) -let rec betree_node_lookup_mut_in_bindings_fwd - (key : u64) (bindings : betree_list_t (u64 & u64)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_lookup_mut_in_bindings_decreases key bindings)) +let rec betree_Node_lookup_mut_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_lookup_mut_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i >= key - then Return (BetreeListCons (i, i0) tl) - else betree_node_lookup_mut_in_bindings_fwd key tl - | BetreeListNil -> Return BetreeListNil + then Return (Betree_List_Cons (i, i0) tl) + else betree_Node_lookup_mut_in_bindings key tl + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) -let rec betree_node_lookup_mut_in_bindings_back - (key : u64) (bindings : betree_list_t (u64 & u64)) - (ret : betree_list_t (u64 & u64)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_lookup_mut_in_bindings_decreases key bindings)) +let rec betree_Node_lookup_mut_in_bindings_back + (key : u64) (bindings : betree_List_t (u64 & u64)) + (ret : betree_List_t (u64 & u64)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_lookup_mut_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i >= key then Return ret else - let* tl0 = betree_node_lookup_mut_in_bindings_back key tl ret in - Return (BetreeListCons (i, i0) tl0) - | BetreeListNil -> Return ret + let* tl0 = betree_Node_lookup_mut_in_bindings_back key tl ret in + Return (Betree_List_Cons (i, i0) tl0) + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_node_apply_to_leaf_fwd_back - (bindings : betree_list_t (u64 & u64)) (key : u64) - (new_msg : betree_message_t) : - result (betree_list_t (u64 & u64)) +let betree_Node_apply_to_leaf + (bindings : betree_List_t (u64 & u64)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 & u64)) = - let* bindings0 = betree_node_lookup_mut_in_bindings_fwd key bindings in - let* b = betree_list_head_has_key_fwd u64 bindings0 key in + let* bindings0 = betree_Node_lookup_mut_in_bindings key bindings in + let* b = betree_List_head_has_key u64 bindings0 key in if b then - let* hd = betree_list_pop_front_fwd (u64 & u64) bindings0 in + let* hd = betree_List_pop_front (u64 & u64) bindings0 in begin match new_msg with - | BetreeMessageInsert v -> - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - let* bindings2 = - betree_list_push_front_fwd_back (u64 & u64) bindings1 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings2 - | BetreeMessageDelete -> - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 - | BetreeMessageUpsert s -> + | Betree_Message_Insert v -> + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + let* bindings2 = betree_List_push_front (u64 & u64) bindings1 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings2 + | Betree_Message_Delete -> + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Upsert s -> let (_, i) = hd in - let* v = betree_upsert_update_fwd (Some i) s in - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - let* bindings2 = - betree_list_push_front_fwd_back (u64 & u64) bindings1 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings2 + let* v = betree_upsert_update (Some i) s in + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + let* bindings2 = betree_List_push_front (u64 & u64) bindings1 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings2 end else begin match new_msg with - | BetreeMessageInsert v -> - let* bindings1 = - betree_list_push_front_fwd_back (u64 & u64) bindings0 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 - | BetreeMessageDelete -> - betree_node_lookup_mut_in_bindings_back key bindings bindings0 - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd None s in - let* bindings1 = - betree_list_push_front_fwd_back (u64 & u64) bindings0 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Insert v -> + let* bindings1 = betree_List_push_front (u64 & u64) bindings0 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Delete -> + betree_Node_lookup_mut_in_bindings_back key bindings bindings0 + | Betree_Message_Upsert s -> + let* v = betree_upsert_update None s in + let* bindings1 = betree_List_push_front (u64 & u64) bindings0 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 end (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_apply_messages_to_leaf_fwd_back - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_apply_messages_to_leaf_decreases bindings new_msgs)) +let rec betree_Node_apply_messages_to_leaf + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_apply_messages_to_leaf_decreases bindings new_msgs)) = begin match new_msgs with - | BetreeListCons new_msg new_msgs_tl -> + | Betree_List_Cons new_msg new_msgs_tl -> let (i, m) = new_msg in - let* bindings0 = betree_node_apply_to_leaf_fwd_back bindings i m in - betree_node_apply_messages_to_leaf_fwd_back bindings0 new_msgs_tl - | BetreeListNil -> Return bindings + let* bindings0 = betree_Node_apply_to_leaf bindings i m in + betree_Node_apply_messages_to_leaf bindings0 new_msgs_tl + | Betree_List_Nil -> Return bindings end (** [betree_main::betree::Internal::{4}::flush]: forward function *) -let rec betree_internal_flush_fwd - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : - Tot (result (state & (betree_list_t (u64 & betree_message_t)))) +let rec betree_Internal_flush + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : + Tot (result (state & (betree_List_t (u64 & betree_Message_t)))) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (st1, (_, node_id_cnt0)) = - betree_node_apply_messages_back'a self.betree_internal_left params - node_id_cnt msgs_left st st0 in + betree_Node_apply_messages_back'a self.left params node_id_cnt msgs_left + st st0 in let* (st2, ()) = - betree_node_apply_messages_back1 self.betree_internal_left params - node_id_cnt msgs_left st st1 in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back1 self.left params node_id_cnt msgs_left + st st1 in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (st3, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt0 msgs_right st2 in + betree_Node_apply_messages self.right params node_id_cnt0 msgs_right + st2 in let* (st4, (_, _)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt0 msgs_right st2 st3 in + betree_Node_apply_messages_back'a self.right params node_id_cnt0 + msgs_right st2 st3 in let* (st5, ()) = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt0 msgs_right st2 st4 in - Return (st5, BetreeListNil) + betree_Node_apply_messages_back1 self.right params node_id_cnt0 + msgs_right st2 st4 in + Return (st5, Betree_List_Nil) else Return (st2, msgs_right) else let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages self.right params node_id_cnt msgs_right st in let* (st1, (_, _)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt msgs_right st st0 in + betree_Node_apply_messages_back'a self.right params node_id_cnt + msgs_right st st0 in let* (st2, ()) = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt msgs_right st st1 in + betree_Node_apply_messages_back1 self.right params node_id_cnt msgs_right + st st1 in Return (st2, msgs_left) (** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) -and betree_internal_flush_back'a - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) (st0 : state) +and betree_Internal_flush_back'a + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) (st0 : state) : - Tot (result (state & (betree_internal_t & betree_node_id_counter_t))) + Tot (result (state & (betree_Internal_t & betree_NodeIdCounter_t))) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (st2, (n, node_id_cnt0)) = - betree_node_apply_messages_back'a self.betree_internal_left params - node_id_cnt msgs_left st st1 in + betree_Node_apply_messages_back'a self.left params node_id_cnt msgs_left + st st1 in let* (st3, ()) = - betree_node_apply_messages_back1 self.betree_internal_left params - node_id_cnt msgs_left st st2 in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back1 self.left params node_id_cnt msgs_left + st st2 in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (st4, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt0 msgs_right st3 in + betree_Node_apply_messages self.right params node_id_cnt0 msgs_right + st3 in let* (st5, (n0, node_id_cnt1)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt0 msgs_right st3 st4 in + betree_Node_apply_messages_back'a self.right params node_id_cnt0 + msgs_right st3 st4 in let* _ = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt0 msgs_right st3 st5 in - Return (st0, - ({ self with betree_internal_left = n; betree_internal_right = n0 }, - node_id_cnt1)) - else Return (st0, ({ self with betree_internal_left = n }, node_id_cnt0)) + betree_Node_apply_messages_back1 self.right params node_id_cnt0 + msgs_right st3 st5 in + Return (st0, ({ self with left = n; right = n0 }, node_id_cnt1)) + else Return (st0, ({ self with left = n }, node_id_cnt0)) else let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages self.right params node_id_cnt msgs_right st in let* (st2, (n, node_id_cnt0)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt msgs_right st st1 in + betree_Node_apply_messages_back'a self.right params node_id_cnt + msgs_right st st1 in let* _ = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt msgs_right st st2 in - Return (st0, ({ self with betree_internal_right = n }, node_id_cnt0)) + betree_Node_apply_messages_back1 self.right params node_id_cnt msgs_right + st st2 in + Return (st0, ({ self with right = n }, node_id_cnt0)) (** [betree_main::betree::Internal::{4}::flush]: backward function 1 *) -and betree_internal_flush_back1 - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) (st0 : state) +and betree_Internal_flush_back1 + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) (st0 : state) : Tot (result (state & unit)) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (st2, (_, node_id_cnt0)) = - betree_node_apply_messages_back'a self.betree_internal_left params - node_id_cnt msgs_left st st1 in + betree_Node_apply_messages_back'a self.left params node_id_cnt msgs_left + st st1 in let* (st3, ()) = - betree_node_apply_messages_back1 self.betree_internal_left params - node_id_cnt msgs_left st st2 in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back1 self.left params node_id_cnt msgs_left + st st2 in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (st4, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt0 msgs_right st3 in + betree_Node_apply_messages self.right params node_id_cnt0 msgs_right + st3 in let* (st5, (_, _)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt0 msgs_right st3 st4 in + betree_Node_apply_messages_back'a self.right params node_id_cnt0 + msgs_right st3 st4 in let* _ = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt0 msgs_right st3 st5 in + betree_Node_apply_messages_back1 self.right params node_id_cnt0 + msgs_right st3 st5 in Return (st0, ()) else Return (st0, ()) else let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages self.right params node_id_cnt msgs_right st in let* (st2, (_, _)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt msgs_right st st1 in + betree_Node_apply_messages_back'a self.right params node_id_cnt + msgs_right st st1 in let* _ = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt msgs_right st st2 in + betree_Node_apply_messages_back1 self.right params node_id_cnt msgs_right + st st2 in Return (st0, ()) (** [betree_main::betree::Node::{5}::apply_messages]: forward function *) -and betree_node_apply_messages_fwd - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : +and betree_Node_apply_messages + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : Tot (result (state & unit)) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st0, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st1, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st0 in + betree_Internal_flush node params node_id_cnt content0 st0 in let* (st2, (node0, _)) = - betree_internal_flush_back'a node params node_id_cnt content0 st0 st1 + betree_Internal_flush_back'a node params node_id_cnt content0 st0 st1 in - let* (st3, _) = - betree_store_internal_node_fwd node0.betree_internal_id content1 st2 in + let* (st3, _) = betree_store_internal_node node0.id content1 st2 in Return (st3, ()) else - let* (st1, _) = - betree_store_internal_node_fwd node.betree_internal_id content0 st0 in + let* (st1, _) = betree_store_internal_node node.id content0 st0 in Return (st1, ()) - | BetreeNodeLeaf node -> - let* (st0, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + | Betree_Node_Leaf node -> + let* (st0, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then - let* (st1, _) = - betree_leaf_split_fwd node content0 params node_id_cnt st0 in - let* (st2, _) = - betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st1 in - betree_leaf_split_back0 node content0 params node_id_cnt st0 st2 + let* (st1, _) = betree_Leaf_split node content0 params node_id_cnt st0 in + let* (st2, _) = betree_store_leaf_node node.id Betree_List_Nil st1 in + betree_Leaf_split_back0 node content0 params node_id_cnt st0 st2 else - let* (st1, _) = - betree_store_leaf_node_fwd node.betree_leaf_id content0 st0 in + let* (st1, _) = betree_store_leaf_node node.id content0 st0 in Return (st1, ()) end (** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) -and betree_node_apply_messages_back'a - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) (st0 : state) : - Tot (result (state & (betree_node_t & betree_node_id_counter_t))) +and betree_Node_apply_messages_back'a + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) (st0 : state) : + Tot (result (state & (betree_Node_t & betree_NodeIdCounter_t))) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st1, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st1, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st2, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st1 in + betree_Internal_flush node params node_id_cnt content0 st1 in let* (st3, (node0, node_id_cnt0)) = - betree_internal_flush_back'a node params node_id_cnt content0 st1 st2 + betree_Internal_flush_back'a node params node_id_cnt content0 st1 st2 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id content1 st3 in - Return (st0, (BetreeNodeInternal node0, node_id_cnt0)) + let* _ = betree_store_internal_node node0.id content1 st3 in + Return (st0, (Betree_Node_Internal node0, node_id_cnt0)) else - let* _ = - betree_store_internal_node_fwd node.betree_internal_id content0 st1 in - Return (st0, (BetreeNodeInternal node, node_id_cnt)) - | BetreeNodeLeaf node -> - let* (st1, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + let* _ = betree_store_internal_node node.id content0 st1 in + Return (st0, (Betree_Node_Internal node, node_id_cnt)) + | Betree_Node_Leaf node -> + let* (st1, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then let* (st2, new_node) = - betree_leaf_split_fwd node content0 params node_id_cnt st1 in - let* (st3, _) = - betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st2 in - let* _ = betree_leaf_split_back0 node content0 params node_id_cnt st1 st3 + betree_Leaf_split node content0 params node_id_cnt st1 in + let* (st3, _) = betree_store_leaf_node node.id Betree_List_Nil st2 in + let* _ = betree_Leaf_split_back0 node content0 params node_id_cnt st1 st3 in let* (st4, node_id_cnt0) = - betree_leaf_split_back2 node content0 params node_id_cnt st1 st0 in - Return (st4, (BetreeNodeInternal new_node, node_id_cnt0)) + betree_Leaf_split_back2 node content0 params node_id_cnt st1 st0 in + Return (st4, (Betree_Node_Internal new_node, node_id_cnt0)) else - let* _ = betree_store_leaf_node_fwd node.betree_leaf_id content0 st1 in - Return (st0, (BetreeNodeLeaf { node with betree_leaf_size = len }, - node_id_cnt)) + let* _ = betree_store_leaf_node node.id content0 st1 in + Return (st0, (Betree_Node_Leaf { node with size = len }, node_id_cnt)) end (** [betree_main::betree::Node::{5}::apply_messages]: backward function 1 *) -and betree_node_apply_messages_back1 - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) (st0 : state) : +and betree_Node_apply_messages_back1 + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) (st0 : state) : Tot (result (state & unit)) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st1, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st1, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st2, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st1 in + betree_Internal_flush node params node_id_cnt content0 st1 in let* (st3, (node0, _)) = - betree_internal_flush_back'a node params node_id_cnt content0 st1 st2 + betree_Internal_flush_back'a node params node_id_cnt content0 st1 st2 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id content1 st3 in - betree_internal_flush_back1 node params node_id_cnt content0 st1 st0 + let* _ = betree_store_internal_node node0.id content1 st3 in + betree_Internal_flush_back1 node params node_id_cnt content0 st1 st0 else - let* _ = - betree_store_internal_node_fwd node.betree_internal_id content0 st1 in + let* _ = betree_store_internal_node node.id content0 st1 in Return (st0, ()) - | BetreeNodeLeaf node -> - let* (st1, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + | Betree_Node_Leaf node -> + let* (st1, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then - let* (st2, _) = - betree_leaf_split_fwd node content0 params node_id_cnt st1 in - let* (st3, _) = - betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st2 in - let* _ = betree_leaf_split_back0 node content0 params node_id_cnt st1 st3 + let* (st2, _) = betree_Leaf_split node content0 params node_id_cnt st1 in + let* (st3, _) = betree_store_leaf_node node.id Betree_List_Nil st2 in + let* _ = betree_Leaf_split_back0 node content0 params node_id_cnt st1 st3 in - betree_leaf_split_back1 node content0 params node_id_cnt st1 st0 + betree_Leaf_split_back1 node content0 params node_id_cnt st1 st0 else - let* _ = betree_store_leaf_node_fwd node.betree_leaf_id content0 st1 in - Return (st0, ()) + let* _ = betree_store_leaf_node node.id content0 st1 in Return (st0, ()) end (** [betree_main::betree::Node::{5}::apply]: forward function *) -let betree_node_apply_fwd - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) : +let betree_Node_apply + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : result (state & unit) = - let l = BetreeListNil in + let l = Betree_List_Nil in let* (st0, _) = - betree_node_apply_messages_fwd self params node_id_cnt (BetreeListCons - (key, new_msg) l) st in + betree_Node_apply_messages self params node_id_cnt (Betree_List_Cons (key, + new_msg) l) st in let* (st1, (_, _)) = - betree_node_apply_messages_back'a self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back'a self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st0 in - betree_node_apply_messages_back1 self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back1 self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st1 (** [betree_main::betree::Node::{5}::apply]: backward function 0 *) -let betree_node_apply_back'a - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) (st0 : state) : - result (state & (betree_node_t & betree_node_id_counter_t)) +let betree_Node_apply_back'a + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) (st0 : state) : + result (state & (betree_Node_t & betree_NodeIdCounter_t)) = - let l = BetreeListNil in + let l = Betree_List_Nil in let* (st1, _) = - betree_node_apply_messages_fwd self params node_id_cnt (BetreeListCons - (key, new_msg) l) st in + betree_Node_apply_messages self params node_id_cnt (Betree_List_Cons (key, + new_msg) l) st in let* (st2, (self0, node_id_cnt0)) = - betree_node_apply_messages_back'a self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back'a self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st1 in let* _ = - betree_node_apply_messages_back1 self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back1 self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st2 in Return (st0, (self0, node_id_cnt0)) (** [betree_main::betree::Node::{5}::apply]: backward function 1 *) -let betree_node_apply_back1 - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) (st0 : state) : +let betree_Node_apply_back1 + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) (st0 : state) : result (state & unit) = - let l = BetreeListNil in + let l = Betree_List_Nil in let* (st1, _) = - betree_node_apply_messages_fwd self params node_id_cnt (BetreeListCons - (key, new_msg) l) st in + betree_Node_apply_messages self params node_id_cnt (Betree_List_Cons (key, + new_msg) l) st in let* (st2, (_, _)) = - betree_node_apply_messages_back'a self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back'a self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st1 in let* _ = - betree_node_apply_messages_back1 self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back1 self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st2 in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::new]: forward function *) -let betree_be_tree_new_fwd +let betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : - result (state & betree_be_tree_t) + result (state & betree_BeTree_t) = - let* node_id_cnt = betree_node_id_counter_new_fwd in - let* id = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* (st0, _) = betree_store_leaf_node_fwd id BetreeListNil st in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in + let* node_id_cnt = betree_NodeIdCounter_new in + let* id = betree_NodeIdCounter_fresh_id node_id_cnt in + let* (st0, _) = betree_store_leaf_node id Betree_List_Nil st in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in Return (st0, { - betree_be_tree_params = - { - betree_params_min_flush_size = min_flush_size; - betree_params_split_size = split_size - }; - betree_be_tree_node_id_cnt = node_id_cnt0; - betree_be_tree_root = - (BetreeNodeLeaf { betree_leaf_id = id; betree_leaf_size = 0 }) + params = { min_flush_size = min_flush_size; split_size = split_size }; + node_id_cnt = node_id_cnt0; + root = (Betree_Node_Leaf { id = id; size = 0 }) }) (** [betree_main::betree::BeTree::{6}::apply]: forward function *) -let betree_be_tree_apply_fwd - (self : betree_be_tree_t) (key : u64) (msg : betree_message_t) (st : state) : +let betree_BeTree_apply + (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state & unit) = let* (st0, _) = - betree_node_apply_fwd self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in + betree_Node_apply self.root self.params self.node_id_cnt key msg st in let* (st1, (_, _)) = - betree_node_apply_back'a self.betree_be_tree_root - self.betree_be_tree_params self.betree_be_tree_node_id_cnt key msg st st0 - in - betree_node_apply_back1 self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st st1 + betree_Node_apply_back'a self.root self.params self.node_id_cnt key msg st + st0 in + betree_Node_apply_back1 self.root self.params self.node_id_cnt key msg st st1 (** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) -let betree_be_tree_apply_back - (self : betree_be_tree_t) (key : u64) (msg : betree_message_t) (st : state) +let betree_BeTree_apply_back + (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) (st0 : state) : - result (state & betree_be_tree_t) + result (state & betree_BeTree_t) = let* (st1, _) = - betree_node_apply_fwd self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in + betree_Node_apply self.root self.params self.node_id_cnt key msg st in let* (st2, (n, nic)) = - betree_node_apply_back'a self.betree_be_tree_root - self.betree_be_tree_params self.betree_be_tree_node_id_cnt key msg st st1 - in + betree_Node_apply_back'a self.root self.params self.node_id_cnt key msg st + st1 in let* _ = - betree_node_apply_back1 self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st st2 in - Return (st0, - { self with betree_be_tree_node_id_cnt = nic; betree_be_tree_root = n }) + betree_Node_apply_back1 self.root self.params self.node_id_cnt key msg st + st2 in + Return (st0, { self with node_id_cnt = nic; root = n }) (** [betree_main::betree::BeTree::{6}::insert]: forward function *) -let betree_be_tree_insert_fwd - (self : betree_be_tree_t) (key : u64) (value : u64) (st : state) : +let betree_BeTree_insert + (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state & unit) = - let* (st0, _) = - betree_be_tree_apply_fwd self key (BetreeMessageInsert value) st in + let* (st0, _) = betree_BeTree_apply self key (Betree_Message_Insert value) st + in let* (st1, _) = - betree_be_tree_apply_back self key (BetreeMessageInsert value) st st0 in + betree_BeTree_apply_back self key (Betree_Message_Insert value) st st0 in Return (st1, ()) (** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) -let betree_be_tree_insert_back - (self : betree_be_tree_t) (key : u64) (value : u64) (st : state) - (st0 : state) : - result (state & betree_be_tree_t) +let betree_BeTree_insert_back + (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) (st0 : state) + : + result (state & betree_BeTree_t) = - let* (st1, _) = - betree_be_tree_apply_fwd self key (BetreeMessageInsert value) st in + let* (st1, _) = betree_BeTree_apply self key (Betree_Message_Insert value) st + in let* (_, self0) = - betree_be_tree_apply_back self key (BetreeMessageInsert value) st st1 in + betree_BeTree_apply_back self key (Betree_Message_Insert value) st st1 in Return (st0, self0) (** [betree_main::betree::BeTree::{6}::delete]: forward function *) -let betree_be_tree_delete_fwd - (self : betree_be_tree_t) (key : u64) (st : state) : result (state & unit) = - let* (st0, _) = betree_be_tree_apply_fwd self key BetreeMessageDelete st in - let* (st1, _) = betree_be_tree_apply_back self key BetreeMessageDelete st st0 - in +let betree_BeTree_delete + (self : betree_BeTree_t) (key : u64) (st : state) : result (state & unit) = + let* (st0, _) = betree_BeTree_apply self key Betree_Message_Delete st in + let* (st1, _) = + betree_BeTree_apply_back self key Betree_Message_Delete st st0 in Return (st1, ()) (** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) -let betree_be_tree_delete_back - (self : betree_be_tree_t) (key : u64) (st : state) (st0 : state) : - result (state & betree_be_tree_t) +let betree_BeTree_delete_back + (self : betree_BeTree_t) (key : u64) (st : state) (st0 : state) : + result (state & betree_BeTree_t) = - let* (st1, _) = betree_be_tree_apply_fwd self key BetreeMessageDelete st in + let* (st1, _) = betree_BeTree_apply self key Betree_Message_Delete st in let* (_, self0) = - betree_be_tree_apply_back self key BetreeMessageDelete st st1 in + betree_BeTree_apply_back self key Betree_Message_Delete st st1 in Return (st0, self0) (** [betree_main::betree::BeTree::{6}::upsert]: forward function *) -let betree_be_tree_upsert_fwd - (self : betree_be_tree_t) (key : u64) (upd : betree_upsert_fun_state_t) +let betree_BeTree_upsert + (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : result (state & unit) = - let* (st0, _) = - betree_be_tree_apply_fwd self key (BetreeMessageUpsert upd) st in + let* (st0, _) = betree_BeTree_apply self key (Betree_Message_Upsert upd) st + in let* (st1, _) = - betree_be_tree_apply_back self key (BetreeMessageUpsert upd) st st0 in + betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st st0 in Return (st1, ()) (** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) -let betree_be_tree_upsert_back - (self : betree_be_tree_t) (key : u64) (upd : betree_upsert_fun_state_t) +let betree_BeTree_upsert_back + (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) (st0 : state) : - result (state & betree_be_tree_t) + result (state & betree_BeTree_t) = - let* (st1, _) = - betree_be_tree_apply_fwd self key (BetreeMessageUpsert upd) st in + let* (st1, _) = betree_BeTree_apply self key (Betree_Message_Upsert upd) st + in let* (_, self0) = - betree_be_tree_apply_back self key (BetreeMessageUpsert upd) st st1 in + betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st st1 in Return (st0, self0) (** [betree_main::betree::BeTree::{6}::lookup]: forward function *) -let betree_be_tree_lookup_fwd - (self : betree_be_tree_t) (key : u64) (st : state) : +let betree_BeTree_lookup + (self : betree_BeTree_t) (key : u64) (st : state) : result (state & (option u64)) = - betree_node_lookup_fwd self.betree_be_tree_root key st + betree_Node_lookup self.root key st (** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) -let betree_be_tree_lookup_back - (self : betree_be_tree_t) (key : u64) (st : state) (st0 : state) : - result (state & betree_be_tree_t) +let betree_BeTree_lookup_back + (self : betree_BeTree_t) (key : u64) (st : state) (st0 : state) : + result (state & betree_BeTree_t) = - let* (st1, n) = betree_node_lookup_back self.betree_be_tree_root key st st0 - in - Return (st1, { self with betree_be_tree_root = n }) + let* (st1, n) = betree_Node_lookup_back self.root key st st0 in + Return (st1, { self with root = n }) (** [betree_main::main]: forward function *) -let main_fwd : result unit = +let main : result unit = Return () (** Unit test for [betree_main::main] *) -let _ = assert_norm (main_fwd = Return ()) +let _ = assert_norm (main = Return ()) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti index c33cf225..c5d0a814 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti +++ b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti @@ -7,24 +7,24 @@ include BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree_utils::load_internal_node]: forward function *) -val betree_utils_load_internal_node_fwd - : u64 -> state -> result (state & (betree_list_t (u64 & betree_message_t))) +val betree_utils_load_internal_node + : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) (** [betree_main::betree_utils::store_internal_node]: forward function *) -val betree_utils_store_internal_node_fwd +val betree_utils_store_internal_node : - u64 -> betree_list_t (u64 & betree_message_t) -> state -> result (state & + u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & unit) (** [betree_main::betree_utils::load_leaf_node]: forward function *) -val betree_utils_load_leaf_node_fwd - : u64 -> state -> result (state & (betree_list_t (u64 & u64))) +val betree_utils_load_leaf_node + : u64 -> state -> result (state & (betree_List_t (u64 & u64))) (** [betree_main::betree_utils::store_leaf_node]: forward function *) -val betree_utils_store_leaf_node_fwd - : u64 -> betree_list_t (u64 & u64) -> state -> result (state & unit) +val betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) (** [core::option::Option::{0}::unwrap]: forward function *) -val core_option_option_unwrap_fwd +val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti index a937c726..9320f6b7 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti +++ b/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti @@ -6,53 +6,47 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree::List] *) -type betree_list_t (t : Type0) = -| BetreeListCons : t -> betree_list_t t -> betree_list_t t -| BetreeListNil : betree_list_t t +type betree_List_t (t : Type0) = +| Betree_List_Cons : t -> betree_List_t t -> betree_List_t t +| Betree_List_Nil : betree_List_t t (** [betree_main::betree::UpsertFunState] *) -type betree_upsert_fun_state_t = -| BetreeUpsertFunStateAdd : u64 -> betree_upsert_fun_state_t -| BetreeUpsertFunStateSub : u64 -> betree_upsert_fun_state_t +type betree_UpsertFunState_t = +| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t +| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t (** [betree_main::betree::Message] *) -type betree_message_t = -| BetreeMessageInsert : u64 -> betree_message_t -| BetreeMessageDelete : betree_message_t -| BetreeMessageUpsert : betree_upsert_fun_state_t -> betree_message_t +type betree_Message_t = +| Betree_Message_Insert : u64 -> betree_Message_t +| Betree_Message_Delete : betree_Message_t +| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t (** [betree_main::betree::Leaf] *) -type betree_leaf_t = { betree_leaf_id : u64; betree_leaf_size : u64; } +type betree_Leaf_t = { id : u64; size : u64; } (** [betree_main::betree::Internal] *) -type betree_internal_t = +type betree_Internal_t = { - betree_internal_id : u64; - betree_internal_pivot : u64; - betree_internal_left : betree_node_t; - betree_internal_right : betree_node_t; + id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; } (** [betree_main::betree::Node] *) -and betree_node_t = -| BetreeNodeInternal : betree_internal_t -> betree_node_t -| BetreeNodeLeaf : betree_leaf_t -> betree_node_t +and betree_Node_t = +| Betree_Node_Internal : betree_Internal_t -> betree_Node_t +| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t (** [betree_main::betree::Params] *) -type betree_params_t = -{ - betree_params_min_flush_size : u64; betree_params_split_size : u64; -} +type betree_Params_t = { min_flush_size : u64; split_size : u64; } (** [betree_main::betree::NodeIdCounter] *) -type betree_node_id_counter_t = { betree_node_id_counter_next_node_id : u64; } +type betree_NodeIdCounter_t = { next_node_id : u64; } (** [betree_main::betree::BeTree] *) -type betree_be_tree_t = +type betree_BeTree_t = { - betree_be_tree_params : betree_params_t; - betree_be_tree_node_id_cnt : betree_node_id_counter_t; - betree_be_tree_root : betree_node_t; + params : betree_Params_t; + node_id_cnt : betree_NodeIdCounter_t; + root : betree_Node_t; } (** The state type used in the state-error monad *) diff --git a/tests/fstar/betree_back_stateful/Primitives.fst b/tests/fstar/betree_back_stateful/Primitives.fst index 9db82069..3297803c 100644 --- a/tests/fstar/betree_back_stateful/Primitives.fst +++ b/tests/fstar/betree_back_stateful/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -169,17 +187,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize @@ -231,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -259,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -278,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -295,55 +389,54 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -358,18 +451,279 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst index 640ae783..a1f81666 100644 --- a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst +++ b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst @@ -8,55 +8,55 @@ open Hashmap.Types (** [hashmap::HashMap::{0}::allocate_slots]: decreases clause *) unfold -let hash_map_allocate_slots_loop_decreases (t : Type0) (slots : vec (list_t t)) - (n : usize) : nat = +let hashMap_allocate_slots_loop_decreases (t : Type0) + (slots : alloc_vec_Vec (list_t t)) (n : usize) : nat = admit () (** [hashmap::HashMap::{0}::clear]: decreases clause *) unfold -let hash_map_clear_loop_decreases (t : Type0) (slots : vec (list_t t)) +let hashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = admit () (** [hashmap::HashMap::{0}::insert_in_list]: decreases clause *) unfold -let hash_map_insert_in_list_loop_decreases (t : Type0) (key : usize) - (value : t) (ls : list_t t) : nat = +let hashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) + (ls : list_t t) : nat = admit () (** [hashmap::HashMap::{0}::move_elements_from_list]: decreases clause *) unfold -let hash_map_move_elements_from_list_loop_decreases (t : Type0) - (ntable : hash_map_t t) (ls : list_t t) : nat = +let hashMap_move_elements_from_list_loop_decreases (t : Type0) + (ntable : hashMap_t t) (ls : list_t t) : nat = admit () (** [hashmap::HashMap::{0}::move_elements]: decreases clause *) unfold -let hash_map_move_elements_loop_decreases (t : Type0) (ntable : hash_map_t t) - (slots : vec (list_t t)) (i : usize) : nat = +let hashMap_move_elements_loop_decreases (t : Type0) (ntable : hashMap_t t) + (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = admit () (** [hashmap::HashMap::{0}::contains_key_in_list]: decreases clause *) unfold -let hash_map_contains_key_in_list_loop_decreases (t : Type0) (key : usize) +let hashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () (** [hashmap::HashMap::{0}::get_in_list]: decreases clause *) unfold -let hash_map_get_in_list_loop_decreases (t : Type0) (key : usize) +let hashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () (** [hashmap::HashMap::{0}::get_mut_in_list]: decreases clause *) unfold -let hash_map_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) +let hashMap_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) (key : usize) : nat = admit () (** [hashmap::HashMap::{0}::remove_from_list]: decreases clause *) unfold -let hash_map_remove_from_list_loop_decreases (t : Type0) (key : usize) +let hashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () diff --git a/tests/fstar/hashmap/Hashmap.Clauses.fst b/tests/fstar/hashmap/Hashmap.Clauses.fst index d8bb8d20..6c699d05 100644 --- a/tests/fstar/hashmap/Hashmap.Clauses.fst +++ b/tests/fstar/hashmap/Hashmap.Clauses.fst @@ -8,54 +8,54 @@ open Hashmap.Types (** [hashmap::HashMap::allocate_slots]: decreases clause *) unfold -let hash_map_allocate_slots_loop_decreases (t : Type0) (slots : vec (list_t t)) - (n : usize) : nat = n +let hashMap_allocate_slots_loop_decreases (t : Type0) + (slots : alloc_vec_Vec (list_t t)) (n : usize) : nat = n (** [hashmap::HashMap::clear]: decreases clause *) unfold -let hash_map_clear_loop_decreases (t : Type0) (slots : vec (list_t t)) +let hashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = if i < length slots then length slots - i else 0 (** [hashmap::HashMap::insert_in_list]: decreases clause *) unfold -let hash_map_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) +let hashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) (ls : list_t t) : list_t t = ls (** [hashmap::HashMap::move_elements_from_list]: decreases clause *) unfold -let hash_map_move_elements_from_list_loop_decreases (t : Type0) - (ntable : hash_map_t t) (ls : list_t t) : list_t t = +let hashMap_move_elements_from_list_loop_decreases (t : Type0) + (ntable : hashMap_t t) (ls : list_t t) : list_t t = ls (** [hashmap::HashMap::move_elements]: decreases clause *) unfold -let hash_map_move_elements_loop_decreases (t : Type0) (ntable : hash_map_t t) - (slots : vec (list_t t)) (i : usize) : nat = +let hashMap_move_elements_loop_decreases (t : Type0) (ntable : hashMap_t t) + (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = if i < length slots then length slots - i else 0 (** [hashmap::HashMap::contains_key_in_list]: decreases clause *) unfold -let hash_map_contains_key_in_list_loop_decreases (t : Type0) (key : usize) +let hashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : list_t t = ls (** [hashmap::HashMap::get_in_list]: decreases clause *) unfold -let hash_map_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : +let hashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : list_t t = ls (** [hashmap::HashMap::get_mut_in_list]: decreases clause *) unfold -let hash_map_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) +let hashMap_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) (key : usize) : list_t t = ls (** [hashmap::HashMap::remove_from_list]: decreases clause *) unfold -let hash_map_remove_from_list_loop_decreases (t : Type0) (key : usize) +let hashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : list_t t = ls diff --git a/tests/fstar/hashmap/Hashmap.Funs.fst b/tests/fstar/hashmap/Hashmap.Funs.fst index f4c13a7b..0e31e364 100644 --- a/tests/fstar/hashmap/Hashmap.Funs.fst +++ b/tests/fstar/hashmap/Hashmap.Funs.fst @@ -8,460 +8,486 @@ include Hashmap.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [hashmap::hash_key]: forward function *) -let hash_key_fwd (k : usize) : result usize = +let hash_key (k : usize) : result usize = Return k (** [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) -let rec hash_map_allocate_slots_loop_fwd - (t : Type0) (slots : vec (list_t t)) (n : usize) : - Tot (result (vec (list_t t))) - (decreases (hash_map_allocate_slots_loop_decreases t slots n)) +let rec hashMap_allocate_slots_loop + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : + Tot (result (alloc_vec_Vec (list_t t))) + (decreases (hashMap_allocate_slots_loop_decreases t slots n)) = if n > 0 then - let* slots0 = vec_push_back (list_t t) slots ListNil in + let* slots0 = alloc_vec_Vec_push (list_t t) slots List_Nil in let* n0 = usize_sub n 1 in - hash_map_allocate_slots_loop_fwd t slots0 n0 + hashMap_allocate_slots_loop t slots0 n0 else Return slots (** [hashmap::HashMap::{0}::allocate_slots]: forward function *) -let hash_map_allocate_slots_fwd - (t : Type0) (slots : vec (list_t t)) (n : usize) : result (vec (list_t t)) = - hash_map_allocate_slots_loop_fwd t slots n +let hashMap_allocate_slots + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : + result (alloc_vec_Vec (list_t t)) + = + hashMap_allocate_slots_loop t slots n (** [hashmap::HashMap::{0}::new_with_capacity]: forward function *) -let hash_map_new_with_capacity_fwd +let hashMap_new_with_capacity (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : - result (hash_map_t t) + result (hashMap_t t) = - let v = vec_new (list_t t) in - let* slots = hash_map_allocate_slots_fwd t v capacity in + let v = alloc_vec_Vec_new (list_t t) in + let* slots = hashMap_allocate_slots t v capacity in let* i = usize_mul capacity max_load_dividend in let* i0 = usize_div i max_load_divisor in Return { - hash_map_num_entries = 0; - hash_map_max_load_factor = (max_load_dividend, max_load_divisor); - hash_map_max_load = i0; - hash_map_slots = slots + num_entries = 0; + max_load_factor = (max_load_dividend, max_load_divisor); + max_load = i0; + slots = slots } (** [hashmap::HashMap::{0}::new]: forward function *) -let hash_map_new_fwd (t : Type0) : result (hash_map_t t) = - hash_map_new_with_capacity_fwd t 32 4 5 +let hashMap_new (t : Type0) : result (hashMap_t t) = + hashMap_new_with_capacity t 32 4 5 (** [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hash_map_clear_loop_fwd_back - (t : Type0) (slots : vec (list_t t)) (i : usize) : - Tot (result (vec (list_t t))) - (decreases (hash_map_clear_loop_decreases t slots i)) +let rec hashMap_clear_loop + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : + Tot (result (alloc_vec_Vec (list_t t))) + (decreases (hashMap_clear_loop_decreases t slots i)) = - let i0 = vec_len (list_t t) slots in + let i0 = alloc_vec_Vec_len (list_t t) slots in if i < i0 then let* i1 = usize_add i 1 in - let* slots0 = vec_index_mut_back (list_t t) slots i ListNil in - hash_map_clear_loop_fwd_back t slots0 i1 + let* slots0 = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots + i List_Nil in + hashMap_clear_loop t slots0 i1 else Return slots (** [hashmap::HashMap::{0}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_clear_fwd_back - (t : Type0) (self : hash_map_t t) : result (hash_map_t t) = - let* v = hash_map_clear_loop_fwd_back t self.hash_map_slots 0 in - Return { self with hash_map_num_entries = 0; hash_map_slots = v } +let hashMap_clear (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = + let* v = hashMap_clear_loop t self.slots 0 in + Return { self with num_entries = 0; slots = v } (** [hashmap::HashMap::{0}::len]: forward function *) -let hash_map_len_fwd (t : Type0) (self : hash_map_t t) : result usize = - Return self.hash_map_num_entries +let hashMap_len (t : Type0) (self : hashMap_t t) : result usize = + Return self.num_entries (** [hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) -let rec hash_map_insert_in_list_loop_fwd +let rec hashMap_insert_in_list_loop (t : Type0) (key : usize) (value : t) (ls : list_t t) : Tot (result bool) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) = begin match ls with - | ListCons ckey cvalue tl -> + | List_Cons ckey cvalue tl -> if ckey = key then Return false - else hash_map_insert_in_list_loop_fwd t key value tl - | ListNil -> Return true + else hashMap_insert_in_list_loop t key value tl + | List_Nil -> Return true end (** [hashmap::HashMap::{0}::insert_in_list]: forward function *) -let hash_map_insert_in_list_fwd +let hashMap_insert_in_list (t : Type0) (key : usize) (value : t) (ls : list_t t) : result bool = - hash_map_insert_in_list_loop_fwd t key value ls + hashMap_insert_in_list_loop t key value ls (** [hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) -let rec hash_map_insert_in_list_loop_back +let rec hashMap_insert_in_list_loop_back (t : Type0) (key : usize) (value : t) (ls : list_t t) : Tot (result (list_t t)) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) = begin match ls with - | ListCons ckey cvalue tl -> + | List_Cons ckey cvalue tl -> if ckey = key - then Return (ListCons ckey value tl) + then Return (List_Cons ckey value tl) else - let* tl0 = hash_map_insert_in_list_loop_back t key value tl in - Return (ListCons ckey cvalue tl0) - | ListNil -> let l = ListNil in Return (ListCons key value l) + let* tl0 = hashMap_insert_in_list_loop_back t key value tl in + Return (List_Cons ckey cvalue tl0) + | List_Nil -> let l = List_Nil in Return (List_Cons key value l) end (** [hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) -let hash_map_insert_in_list_back +let hashMap_insert_in_list_back (t : Type0) (key : usize) (value : t) (ls : list_t t) : result (list_t t) = - hash_map_insert_in_list_loop_back t key value ls + hashMap_insert_in_list_loop_back t key value ls (** [hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_insert_no_resize_fwd_back - (t : Type0) (self : hash_map_t t) (key : usize) (value : t) : - result (hash_map_t t) +let hashMap_insert_no_resize + (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : + result (hashMap_t t) = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - let* inserted = hash_map_insert_in_list_fwd t key value l in + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + let* inserted = hashMap_insert_in_list t key value l in if inserted then - let* i0 = usize_add self.hash_map_num_entries 1 in - let* l0 = hash_map_insert_in_list_back t key value l in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_num_entries = i0; hash_map_slots = v } + let* i0 = usize_add self.num_entries 1 in + let* l0 = hashMap_insert_in_list_back t key value l in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with num_entries = i0; slots = v } else - let* l0 = hash_map_insert_in_list_back t key value l in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_slots = v } - -(** [core::num::u32::{8}::MAX] *) -let core_num_u32_max_body : result u32 = Return 4294967295 -let core_num_u32_max_c : u32 = eval_global core_num_u32_max_body + let* l0 = hashMap_insert_in_list_back t key value l in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with slots = v } (** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hash_map_move_elements_from_list_loop_fwd_back - (t : Type0) (ntable : hash_map_t t) (ls : list_t t) : - Tot (result (hash_map_t t)) - (decreases (hash_map_move_elements_from_list_loop_decreases t ntable ls)) +let rec hashMap_move_elements_from_list_loop + (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : + Tot (result (hashMap_t t)) + (decreases (hashMap_move_elements_from_list_loop_decreases t ntable ls)) = begin match ls with - | ListCons k v tl -> - let* ntable0 = hash_map_insert_no_resize_fwd_back t ntable k v in - hash_map_move_elements_from_list_loop_fwd_back t ntable0 tl - | ListNil -> Return ntable + | List_Cons k v tl -> + let* ntable0 = hashMap_insert_no_resize t ntable k v in + hashMap_move_elements_from_list_loop t ntable0 tl + | List_Nil -> Return ntable end (** [hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_move_elements_from_list_fwd_back - (t : Type0) (ntable : hash_map_t t) (ls : list_t t) : result (hash_map_t t) = - hash_map_move_elements_from_list_loop_fwd_back t ntable ls +let hashMap_move_elements_from_list + (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : result (hashMap_t t) = + hashMap_move_elements_from_list_loop t ntable ls (** [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hash_map_move_elements_loop_fwd_back - (t : Type0) (ntable : hash_map_t t) (slots : vec (list_t t)) (i : usize) : - Tot (result ((hash_map_t t) & (vec (list_t t)))) - (decreases (hash_map_move_elements_loop_decreases t ntable slots i)) +let rec hashMap_move_elements_loop + (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) + (i : usize) : + Tot (result ((hashMap_t t) & (alloc_vec_Vec (list_t t)))) + (decreases (hashMap_move_elements_loop_decreases t ntable slots i)) = - let i0 = vec_len (list_t t) slots in + let i0 = alloc_vec_Vec_len (list_t t) slots in if i < i0 then - let* l = vec_index_mut_fwd (list_t t) slots i in - let ls = mem_replace_fwd (list_t t) l ListNil in - let* ntable0 = hash_map_move_elements_from_list_fwd_back t ntable ls in + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots + i in + let ls = core_mem_replace (list_t t) l List_Nil in + let* ntable0 = hashMap_move_elements_from_list t ntable ls in let* i1 = usize_add i 1 in - let l0 = mem_replace_back (list_t t) l ListNil in - let* slots0 = vec_index_mut_back (list_t t) slots i l0 in - hash_map_move_elements_loop_fwd_back t ntable0 slots0 i1 + let l0 = core_mem_replace_back (list_t t) l List_Nil in + let* slots0 = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots + i l0 in + hashMap_move_elements_loop t ntable0 slots0 i1 else Return (ntable, slots) (** [hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_move_elements_fwd_back - (t : Type0) (ntable : hash_map_t t) (slots : vec (list_t t)) (i : usize) : - result ((hash_map_t t) & (vec (list_t t))) +let hashMap_move_elements + (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) + (i : usize) : + result ((hashMap_t t) & (alloc_vec_Vec (list_t t))) = - hash_map_move_elements_loop_fwd_back t ntable slots i + hashMap_move_elements_loop t ntable slots i (** [hashmap::HashMap::{0}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_try_resize_fwd_back - (t : Type0) (self : hash_map_t t) : result (hash_map_t t) = - let* max_usize = scalar_cast U32 Usize core_num_u32_max_c in - let capacity = vec_len (list_t t) self.hash_map_slots in +let hashMap_try_resize + (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = + let* max_usize = scalar_cast U32 Usize core_u32_max in + let capacity = alloc_vec_Vec_len (list_t t) self.slots in let* n1 = usize_div max_usize 2 in - let (i, i0) = self.hash_map_max_load_factor in + let (i, i0) = self.max_load_factor in let* i1 = usize_div n1 i in if capacity <= i1 then let* i2 = usize_mul capacity 2 in - let* ntable = hash_map_new_with_capacity_fwd t i2 i i0 in - let* (ntable0, _) = - hash_map_move_elements_fwd_back t ntable self.hash_map_slots 0 in + let* ntable = hashMap_new_with_capacity t i2 i i0 in + let* (ntable0, _) = hashMap_move_elements t ntable self.slots 0 in Return - { - ntable0 - with - hash_map_num_entries = self.hash_map_num_entries; - hash_map_max_load_factor = (i, i0) + { ntable0 with num_entries = self.num_entries; max_load_factor = (i, i0) } - else Return { self with hash_map_max_load_factor = (i, i0) } + else Return { self with max_load_factor = (i, i0) } (** [hashmap::HashMap::{0}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_insert_fwd_back - (t : Type0) (self : hash_map_t t) (key : usize) (value : t) : - result (hash_map_t t) +let hashMap_insert + (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : + result (hashMap_t t) = - let* self0 = hash_map_insert_no_resize_fwd_back t self key value in - let* i = hash_map_len_fwd t self0 in - if i > self0.hash_map_max_load - then hash_map_try_resize_fwd_back t self0 - else Return self0 + let* self0 = hashMap_insert_no_resize t self key value in + let* i = hashMap_len t self0 in + if i > self0.max_load then hashMap_try_resize t self0 else Return self0 (** [hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) -let rec hash_map_contains_key_in_list_loop_fwd +let rec hashMap_contains_key_in_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result bool) - (decreases (hash_map_contains_key_in_list_loop_decreases t key ls)) + (decreases (hashMap_contains_key_in_list_loop_decreases t key ls)) = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> if ckey = key then Return true - else hash_map_contains_key_in_list_loop_fwd t key tl - | ListNil -> Return false + else hashMap_contains_key_in_list_loop t key tl + | List_Nil -> Return false end (** [hashmap::HashMap::{0}::contains_key_in_list]: forward function *) -let hash_map_contains_key_in_list_fwd +let hashMap_contains_key_in_list (t : Type0) (key : usize) (ls : list_t t) : result bool = - hash_map_contains_key_in_list_loop_fwd t key ls + hashMap_contains_key_in_list_loop t key ls (** [hashmap::HashMap::{0}::contains_key]: forward function *) -let hash_map_contains_key_fwd - (t : Type0) (self : hash_map_t t) (key : usize) : result bool = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_contains_key + (t : Type0) (self : hashMap_t t) (key : usize) : result bool = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_fwd (list_t t) self.hash_map_slots hash_mod in - hash_map_contains_key_in_list_fwd t key l + let* l = + alloc_vec_Vec_index (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + hashMap_contains_key_in_list t key l (** [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) -let rec hash_map_get_in_list_loop_fwd +let rec hashMap_get_in_list_loop (t : Type0) (key : usize) (ls : list_t t) : - Tot (result t) (decreases (hash_map_get_in_list_loop_decreases t key ls)) + Tot (result t) (decreases (hashMap_get_in_list_loop_decreases t key ls)) = begin match ls with - | ListCons ckey cvalue tl -> - if ckey = key - then Return cvalue - else hash_map_get_in_list_loop_fwd t key tl - | ListNil -> Fail Failure + | List_Cons ckey cvalue tl -> + if ckey = key then Return cvalue else hashMap_get_in_list_loop t key tl + | List_Nil -> Fail Failure end (** [hashmap::HashMap::{0}::get_in_list]: forward function *) -let hash_map_get_in_list_fwd - (t : Type0) (key : usize) (ls : list_t t) : result t = - hash_map_get_in_list_loop_fwd t key ls +let hashMap_get_in_list (t : Type0) (key : usize) (ls : list_t t) : result t = + hashMap_get_in_list_loop t key ls (** [hashmap::HashMap::{0}::get]: forward function *) -let hash_map_get_fwd - (t : Type0) (self : hash_map_t t) (key : usize) : result t = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_get (t : Type0) (self : hashMap_t t) (key : usize) : result t = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_fwd (list_t t) self.hash_map_slots hash_mod in - hash_map_get_in_list_fwd t key l + let* l = + alloc_vec_Vec_index (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + hashMap_get_in_list t key l (** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) -let rec hash_map_get_mut_in_list_loop_fwd +let rec hashMap_get_mut_in_list_loop (t : Type0) (ls : list_t t) (key : usize) : - Tot (result t) (decreases (hash_map_get_mut_in_list_loop_decreases t ls key)) + Tot (result t) (decreases (hashMap_get_mut_in_list_loop_decreases t ls key)) = begin match ls with - | ListCons ckey cvalue tl -> - if ckey = key - then Return cvalue - else hash_map_get_mut_in_list_loop_fwd t tl key - | ListNil -> Fail Failure + | List_Cons ckey cvalue tl -> + if ckey = key then Return cvalue else hashMap_get_mut_in_list_loop t tl key + | List_Nil -> Fail Failure end (** [hashmap::HashMap::{0}::get_mut_in_list]: forward function *) -let hash_map_get_mut_in_list_fwd +let hashMap_get_mut_in_list (t : Type0) (ls : list_t t) (key : usize) : result t = - hash_map_get_mut_in_list_loop_fwd t ls key + hashMap_get_mut_in_list_loop t ls key (** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) -let rec hash_map_get_mut_in_list_loop_back +let rec hashMap_get_mut_in_list_loop_back (t : Type0) (ls : list_t t) (key : usize) (ret : t) : Tot (result (list_t t)) - (decreases (hash_map_get_mut_in_list_loop_decreases t ls key)) + (decreases (hashMap_get_mut_in_list_loop_decreases t ls key)) = begin match ls with - | ListCons ckey cvalue tl -> + | List_Cons ckey cvalue tl -> if ckey = key - then Return (ListCons ckey ret tl) + then Return (List_Cons ckey ret tl) else - let* tl0 = hash_map_get_mut_in_list_loop_back t tl key ret in - Return (ListCons ckey cvalue tl0) - | ListNil -> Fail Failure + let* tl0 = hashMap_get_mut_in_list_loop_back t tl key ret in + Return (List_Cons ckey cvalue tl0) + | List_Nil -> Fail Failure end (** [hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) -let hash_map_get_mut_in_list_back +let hashMap_get_mut_in_list_back (t : Type0) (ls : list_t t) (key : usize) (ret : t) : result (list_t t) = - hash_map_get_mut_in_list_loop_back t ls key ret + hashMap_get_mut_in_list_loop_back t ls key ret (** [hashmap::HashMap::{0}::get_mut]: forward function *) -let hash_map_get_mut_fwd - (t : Type0) (self : hash_map_t t) (key : usize) : result t = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_get_mut (t : Type0) (self : hashMap_t t) (key : usize) : result t = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - hash_map_get_mut_in_list_fwd t l key + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + hashMap_get_mut_in_list t l key (** [hashmap::HashMap::{0}::get_mut]: backward function 0 *) -let hash_map_get_mut_back - (t : Type0) (self : hash_map_t t) (key : usize) (ret : t) : - result (hash_map_t t) +let hashMap_get_mut_back + (t : Type0) (self : hashMap_t t) (key : usize) (ret : t) : + result (hashMap_t t) = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - let* l0 = hash_map_get_mut_in_list_back t l key ret in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_slots = v } + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + let* l0 = hashMap_get_mut_in_list_back t l key ret in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with slots = v } (** [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) -let rec hash_map_remove_from_list_loop_fwd +let rec hashMap_remove_from_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result (option t)) - (decreases (hash_map_remove_from_list_loop_decreases t key ls)) + (decreases (hashMap_remove_from_list_loop_decreases t key ls)) = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> if ckey = key then - let mv_ls = mem_replace_fwd (list_t t) (ListCons ckey x tl) ListNil in + let mv_ls = core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in begin match mv_ls with - | ListCons i cvalue tl0 -> Return (Some cvalue) - | ListNil -> Fail Failure + | List_Cons i cvalue tl0 -> Return (Some cvalue) + | List_Nil -> Fail Failure end - else hash_map_remove_from_list_loop_fwd t key tl - | ListNil -> Return None + else hashMap_remove_from_list_loop t key tl + | List_Nil -> Return None end (** [hashmap::HashMap::{0}::remove_from_list]: forward function *) -let hash_map_remove_from_list_fwd +let hashMap_remove_from_list (t : Type0) (key : usize) (ls : list_t t) : result (option t) = - hash_map_remove_from_list_loop_fwd t key ls + hashMap_remove_from_list_loop t key ls (** [hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) -let rec hash_map_remove_from_list_loop_back +let rec hashMap_remove_from_list_loop_back (t : Type0) (key : usize) (ls : list_t t) : Tot (result (list_t t)) - (decreases (hash_map_remove_from_list_loop_decreases t key ls)) + (decreases (hashMap_remove_from_list_loop_decreases t key ls)) = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> if ckey = key then - let mv_ls = mem_replace_fwd (list_t t) (ListCons ckey x tl) ListNil in + let mv_ls = core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in begin match mv_ls with - | ListCons i cvalue tl0 -> Return tl0 - | ListNil -> Fail Failure + | List_Cons i cvalue tl0 -> Return tl0 + | List_Nil -> Fail Failure end else - let* tl0 = hash_map_remove_from_list_loop_back t key tl in - Return (ListCons ckey x tl0) - | ListNil -> Return ListNil + let* tl0 = hashMap_remove_from_list_loop_back t key tl in + Return (List_Cons ckey x tl0) + | List_Nil -> Return List_Nil end (** [hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) -let hash_map_remove_from_list_back +let hashMap_remove_from_list_back (t : Type0) (key : usize) (ls : list_t t) : result (list_t t) = - hash_map_remove_from_list_loop_back t key ls + hashMap_remove_from_list_loop_back t key ls (** [hashmap::HashMap::{0}::remove]: forward function *) -let hash_map_remove_fwd - (t : Type0) (self : hash_map_t t) (key : usize) : result (option t) = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_remove + (t : Type0) (self : hashMap_t t) (key : usize) : result (option t) = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - let* x = hash_map_remove_from_list_fwd t key l in + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + let* x = hashMap_remove_from_list t key l in begin match x with | None -> Return None - | Some x0 -> - let* _ = usize_sub self.hash_map_num_entries 1 in Return (Some x0) + | Some x0 -> let* _ = usize_sub self.num_entries 1 in Return (Some x0) end (** [hashmap::HashMap::{0}::remove]: backward function 0 *) -let hash_map_remove_back - (t : Type0) (self : hash_map_t t) (key : usize) : result (hash_map_t t) = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_remove_back + (t : Type0) (self : hashMap_t t) (key : usize) : result (hashMap_t t) = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - let* x = hash_map_remove_from_list_fwd t key l in + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + let* x = hashMap_remove_from_list t key l in begin match x with | None -> - let* l0 = hash_map_remove_from_list_back t key l in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_slots = v } + let* l0 = hashMap_remove_from_list_back t key l in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with slots = v } | Some x0 -> - let* i0 = usize_sub self.hash_map_num_entries 1 in - let* l0 = hash_map_remove_from_list_back t key l in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_num_entries = i0; hash_map_slots = v } + let* i0 = usize_sub self.num_entries 1 in + let* l0 = hashMap_remove_from_list_back t key l in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with num_entries = i0; slots = v } end (** [hashmap::test1]: forward function *) -let test1_fwd : result unit = - let* hm = hash_map_new_fwd u64 in - let* hm0 = hash_map_insert_fwd_back u64 hm 0 42 in - let* hm1 = hash_map_insert_fwd_back u64 hm0 128 18 in - let* hm2 = hash_map_insert_fwd_back u64 hm1 1024 138 in - let* hm3 = hash_map_insert_fwd_back u64 hm2 1056 256 in - let* i = hash_map_get_fwd u64 hm3 128 in +let test1 : result unit = + let* hm = hashMap_new u64 in + let* hm0 = hashMap_insert u64 hm 0 42 in + let* hm1 = hashMap_insert u64 hm0 128 18 in + let* hm2 = hashMap_insert u64 hm1 1024 138 in + let* hm3 = hashMap_insert u64 hm2 1056 256 in + let* i = hashMap_get u64 hm3 128 in if not (i = 18) then Fail Failure else - let* hm4 = hash_map_get_mut_back u64 hm3 1024 56 in - let* i0 = hash_map_get_fwd u64 hm4 1024 in + let* hm4 = hashMap_get_mut_back u64 hm3 1024 56 in + let* i0 = hashMap_get u64 hm4 1024 in if not (i0 = 56) then Fail Failure else - let* x = hash_map_remove_fwd u64 hm4 1024 in + let* x = hashMap_remove u64 hm4 1024 in begin match x with | None -> Fail Failure | Some x0 -> if not (x0 = 56) then Fail Failure else - let* hm5 = hash_map_remove_back u64 hm4 1024 in - let* i1 = hash_map_get_fwd u64 hm5 0 in + let* hm5 = hashMap_remove_back u64 hm4 1024 in + let* i1 = hashMap_get u64 hm5 0 in if not (i1 = 42) then Fail Failure else - let* i2 = hash_map_get_fwd u64 hm5 128 in + let* i2 = hashMap_get u64 hm5 128 in if not (i2 = 18) then Fail Failure else - let* i3 = hash_map_get_fwd u64 hm5 1056 in + let* i3 = hashMap_get u64 hm5 1056 in if not (i3 = 256) then Fail Failure else Return () end -(** Unit test for [hashmap::test1] *) -let _ = assert_norm (test1_fwd = Return ()) - diff --git a/tests/fstar/hashmap/Hashmap.Properties.fst b/tests/fstar/hashmap/Hashmap.Properties.fst index 49d96cd5..def520f0 100644 --- a/tests/fstar/hashmap/Hashmap.Properties.fst +++ b/tests/fstar/hashmap/Hashmap.Properties.fst @@ -272,7 +272,7 @@ type pos_usize = x:usize{x > 0} type binding (t : Type0) = key & t -type slots_t (t : Type0) = vec (list_t t) +type slots_t (t : Type0) = alloc_vec_Vec (list_t t) /// We represent hash maps as associative lists type assoc_list (t : Type0) = list (binding t) @@ -280,8 +280,8 @@ type assoc_list (t : Type0) = list (binding t) /// Representation function for [list_t] let rec list_t_v (#t : Type0) (ls : list_t t) : assoc_list t = match ls with - | ListNil -> [] - | ListCons k v tl -> (k,v) :: list_t_v tl + | List_Nil -> [] + | List_Cons k v tl -> (k,v) :: list_t_v tl let list_t_len (#t : Type0) (ls : list_t t) : nat = length (list_t_v ls) let list_t_index (#t : Type0) (ls : list_t t) (i : nat{i < list_t_len ls}) : binding t = @@ -305,30 +305,30 @@ let slots_t_al_v (#t : Type0) (slots : slots_t t) : assoc_list t = /// list per slot). This is the representation we use most, internally. Note that /// we later introduce a [map_s] representation, which is the one used in the /// lemmas shown to the user. -type hash_map_s t = list (slot_s t) +type hashMap_s t = list (slot_s t) // TODO: why not always have the condition on the length? // 'nes': "non-empty slots" -type hash_map_s_nes (t : Type0) : Type0 = - hm:hash_map_s t{is_pos_usize (length hm)} +type hashMap_s_nes (t : Type0) : Type0 = + hm:hashMap_s t{is_pos_usize (length hm)} -/// Representation function for [hash_map_t] as a list of slots -let hash_map_t_v (#t : Type0) (hm : hash_map_t t) : hash_map_s t = - map list_t_v hm.hash_map_slots +/// Representation function for [hashMap_t] as a list of slots +let hashMap_t_v (#t : Type0) (hm : hashMap_t t) : hashMap_s t = + map list_t_v hm.slots -/// Representation function for [hash_map_t] as an associative list -let hash_map_t_al_v (#t : Type0) (hm : hash_map_t t) : assoc_list t = - flatten (hash_map_t_v hm) +/// Representation function for [hashMap_t] as an associative list +let hashMap_t_al_v (#t : Type0) (hm : hashMap_t t) : assoc_list t = + flatten (hashMap_t_v hm) // 'nes': "non-empty slots" -type hash_map_t_nes (t : Type0) : Type0 = - hm:hash_map_t t{is_pos_usize (length hm.hash_map_slots)} +type hashMap_t_nes (t : Type0) : Type0 = + hm:hashMap_t t{is_pos_usize (length hm.slots)} -let hash_key (k : key) : hash = - Return?.v (hash_key_fwd k) +let hash_key_s (k : key) : hash = + Return?.v (hash_key k) let hash_mod_key (k : key) (len : usize{len > 0}) : hash = - (hash_key k) % len + (hash_key_s k) % len let not_same_key (#t : Type0) (k : key) (b : binding t) : bool = fst b <> k let same_key (#t : Type0) (k : key) (b : binding t) : bool = fst b = k @@ -339,8 +339,8 @@ let same_hash_mod_key (#t : Type0) (len : usize{len > 0}) (h : nat) (b : binding let binding_neq (#t : Type0) (b0 b1 : binding t) : bool = fst b0 <> fst b1 -let hash_map_t_len_s (#t : Type0) (hm : hash_map_t t) : nat = - hm.hash_map_num_entries +let hashMap_t_len_s (#t : Type0) (hm : hashMap_t t) : nat = + hm.num_entries let assoc_list_find (#t : Type0) (k : key) (slot : assoc_list t) : option t = match find (same_key k) slot with @@ -354,26 +354,26 @@ let slot_t_find_s (#t : Type0) (k : key) (slot : list_t t) : option t = slot_s_find k (slot_t_v slot) // This is a simpler version of the "find" function, which captures the essence -// of what happens and operates on [hash_map_s]. -let hash_map_s_find - (#t : Type0) (hm : hash_map_s_nes t) +// of what happens and operates on [hashMap_s]. +let hashMap_s_find + (#t : Type0) (hm : hashMap_s_nes t) (k : key) : option t = let i = hash_mod_key k (length hm) in let slot = index hm i in slot_s_find k slot -let hash_map_s_len - (#t : Type0) (hm : hash_map_s t) : +let hashMap_s_len + (#t : Type0) (hm : hashMap_s t) : nat = length (flatten hm) -// Same as above, but operates on [hash_map_t] +// Same as above, but operates on [hashMap_t] // Note that we don't reuse the above function on purpose: converting to a -// [hash_map_s] then looking up an element is not the same as what we +// [hashMap_s] then looking up an element is not the same as what we // wrote below. -let hash_map_t_find_s - (#t : Type0) (hm : hash_map_t t{length hm.hash_map_slots > 0}) (k : key) : option t = - let slots = hm.hash_map_slots in +let hashMap_t_find_s + (#t : Type0) (hm : hashMap_t t{length hm.slots > 0}) (k : key) : option t = + let slots = hm.slots in let i = hash_mod_key k (length slots) in let slot = index slots i in slot_t_find_s k slot @@ -404,74 +404,74 @@ let slots_t_inv (#t : Type0) (slots : slots_t t{length slots <= usize_max}) : Ty {:pattern index slots i} slot_t_inv (length slots) i (index slots i) -let hash_map_s_inv (#t : Type0) (hm : hash_map_s t) : Type0 = +let hashMap_s_inv (#t : Type0) (hm : hashMap_s t) : Type0 = length hm <= usize_max /\ length hm > 0 /\ slots_s_inv hm /// Base invariant for the hashmap (the complete invariant can be temporarily /// broken between the moment we inserted an element and the moment we resize) -let hash_map_t_base_inv (#t : Type0) (hm : hash_map_t t) : Type0 = - let al = hash_map_t_al_v hm in +let hashMap_t_base_inv (#t : Type0) (hm : hashMap_t t) : Type0 = + let al = hashMap_t_al_v hm in // [num_entries] correctly tracks the number of entries in the table // Note that it gives us that the length of the slots array is <= usize_max: // [> length <= usize_max - // (because hash_map_num_entries has type `usize`) - hm.hash_map_num_entries = length al /\ + // (because hashMap_num_entries has type `usize`) + hm.num_entries = length al /\ // Slots invariant - slots_t_inv hm.hash_map_slots /\ + slots_t_inv hm.slots /\ // The capacity must be > 0 (otherwise we can't resize, because we // multiply the capacity by two!) - length hm.hash_map_slots > 0 /\ + length hm.slots > 0 /\ // Load computation begin - let capacity = length hm.hash_map_slots in - let (dividend, divisor) = hm.hash_map_max_load_factor in + let capacity = length hm.slots in + let (dividend, divisor) = hm.max_load_factor in 0 < dividend /\ dividend < divisor /\ capacity * dividend >= divisor /\ - hm.hash_map_max_load = (capacity * dividend) / divisor + hm.max_load = (capacity * dividend) / divisor end /// We often need to frame some values -let hash_map_t_same_params (#t : Type0) (hm0 hm1 : hash_map_t t) : Type0 = - length hm0.hash_map_slots = length hm1.hash_map_slots /\ - hm0.hash_map_max_load = hm1.hash_map_max_load /\ - hm0.hash_map_max_load_factor = hm1.hash_map_max_load_factor +let hashMap_t_same_params (#t : Type0) (hm0 hm1 : hashMap_t t) : Type0 = + length hm0.slots = length hm1.slots /\ + hm0.max_load = hm1.max_load /\ + hm0.max_load_factor = hm1.max_load_factor /// The following invariants, etc. are meant to be revealed to the user through /// the .fsti. /// Invariant for the hashmap -let hash_map_t_inv (#t : Type0) (hm : hash_map_t t) : Type0 = +let hashMap_t_inv (#t : Type0) (hm : hashMap_t t) : Type0 = // Base invariant - hash_map_t_base_inv hm /\ + hashMap_t_base_inv hm /\ // The hash map is either: not overloaded, or we can't resize it begin - let (dividend, divisor) = hm.hash_map_max_load_factor in - hm.hash_map_num_entries <= hm.hash_map_max_load - || length hm.hash_map_slots * 2 * dividend > usize_max + let (dividend, divisor) = hm.max_load_factor in + hm.num_entries <= hm.max_load + || length hm.slots * 2 * dividend > usize_max end (*** .fsti *) /// We reveal slightly different version of the above functions to the user -let len_s (#t : Type0) (hm : hash_map_t t) : nat = hash_map_t_len_s hm +let len_s (#t : Type0) (hm : hashMap_t t) : nat = hashMap_t_len_s hm -/// This version doesn't take any precondition (contrary to [hash_map_t_find_s]) -let find_s (#t : Type0) (hm : hash_map_t t) (k : key) : option t = - if length hm.hash_map_slots = 0 then None - else hash_map_t_find_s hm k +/// This version doesn't take any precondition (contrary to [hashMap_t_find_s]) +let find_s (#t : Type0) (hm : hashMap_t t) (k : key) : option t = + if length hm.slots = 0 then None + else hashMap_t_find_s hm k (*** Overloading *) -let hash_map_not_overloaded_lem #t hm = () +let hashMap_not_overloaded_lem #t hm = () (*** allocate_slots *) /// Auxiliary lemma val slots_t_all_nil_inv_lem - (#t : Type0) (slots : vec (list_t t){length slots <= usize_max}) : - Lemma (requires (forall (i:nat{i < length slots}). index slots i == ListNil)) + (#t : Type0) (slots : alloc_vec_Vec (list_t t){length slots <= usize_max}) : + Lemma (requires (forall (i:nat{i < length slots}). index slots i == List_Nil)) (ensures (slots_t_inv slots)) #push-options "--fuel 1" @@ -479,8 +479,8 @@ let slots_t_all_nil_inv_lem #t slots = () #pop-options val slots_t_al_v_all_nil_is_empty_lem - (#t : Type0) (slots : vec (list_t t)) : - Lemma (requires (forall (i:nat{i < length slots}). index slots i == ListNil)) + (#t : Type0) (slots : alloc_vec_Vec (list_t t)) : + Lemma (requires (forall (i:nat{i < length slots}). index slots i == List_Nil)) (ensures (slots_t_al_v slots == [])) #push-options "--fuel 1" @@ -492,44 +492,44 @@ let rec slots_t_al_v_all_nil_is_empty_lem #t slots = slots_t_al_v_all_nil_is_empty_lem #t slots'; assert(slots_t_al_v slots == list_t_v s @ slots_t_al_v slots'); assert(slots_t_al_v slots == list_t_v s); - assert(index slots 0 == ListNil) + assert(index slots 0 == List_Nil) #pop-options /// [allocate_slots] -val hash_map_allocate_slots_fwd_lem - (t : Type0) (slots : vec (list_t t)) (n : usize) : +val hashMap_allocate_slots_lem + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : Lemma (requires (length slots + n <= usize_max)) (ensures ( - match hash_map_allocate_slots_fwd t slots n with + match hashMap_allocate_slots t slots n with | Fail _ -> False | Return slots' -> length slots' = length slots + n /\ // We leave the already allocated slots unchanged (forall (i:nat{i < length slots}). index slots' i == index slots i) /\ // We allocate n additional empty slots - (forall (i:nat{length slots <= i /\ i < length slots'}). index slots' i == ListNil))) - (decreases (hash_map_allocate_slots_loop_decreases t slots n)) + (forall (i:nat{length slots <= i /\ i < length slots'}). index slots' i == List_Nil))) + (decreases (hashMap_allocate_slots_loop_decreases t slots n)) #push-options "--fuel 1" -let rec hash_map_allocate_slots_fwd_lem t slots n = +let rec hashMap_allocate_slots_lem t slots n = begin match n with | 0 -> () | _ -> - begin match vec_push_back (list_t t) slots ListNil with + begin match alloc_vec_Vec_push (list_t t) slots List_Nil with | Fail _ -> () | Return slots1 -> begin match usize_sub n 1 with | Fail _ -> () | Return i -> - hash_map_allocate_slots_fwd_lem t slots1 i; - begin match hash_map_allocate_slots_fwd t slots1 i with + hashMap_allocate_slots_lem t slots1 i; + begin match hashMap_allocate_slots t slots1 i with | Fail _ -> () | Return slots2 -> assert(length slots1 = length slots + 1); - assert(slots1 == slots @ [ListNil]); // Triggers patterns - assert(index slots1 (length slots) == index [ListNil] 0); // Triggers patterns - assert(index slots1 (length slots) == ListNil) + assert(slots1 == slots @ [List_Nil]); // Triggers patterns + assert(index slots1 (length slots) == index [List_Nil] 0); // Triggers patterns + assert(index slots1 (length slots) == List_Nil) end end end @@ -538,7 +538,7 @@ let rec hash_map_allocate_slots_fwd_lem t slots n = (*** new_with_capacity *) /// Under proper conditions, [new_with_capacity] doesn't fail and returns an empty hash map. -val hash_map_new_with_capacity_fwd_lem +val hashMap_new_with_capacity_lem (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : Lemma @@ -549,31 +549,31 @@ val hash_map_new_with_capacity_fwd_lem capacity * max_load_dividend >= max_load_divisor /\ capacity * max_load_dividend <= usize_max)) (ensures ( - match hash_map_new_with_capacity_fwd t capacity max_load_dividend max_load_divisor with + match hashMap_new_with_capacity t capacity max_load_dividend max_load_divisor with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // The parameters are correct - hm.hash_map_max_load_factor = (max_load_dividend, max_load_divisor) /\ - hm.hash_map_max_load = (capacity * max_load_dividend) / max_load_divisor /\ + hm.max_load_factor = (max_load_dividend, max_load_divisor) /\ + hm.max_load = (capacity * max_load_dividend) / max_load_divisor /\ // The hash map has the specified capacity - we need to reveal this - // otherwise the pre of [hash_map_t_find_s] is not satisfied. - length hm.hash_map_slots = capacity /\ + // otherwise the pre of [hashMap_t_find_s] is not satisfied. + length hm.slots = capacity /\ // The hash map has 0 values - hash_map_t_len_s hm = 0 /\ + hashMap_t_len_s hm = 0 /\ // It contains no bindings - (forall k. hash_map_t_find_s hm k == None) /\ + (forall k. hashMap_t_find_s hm k == None) /\ // We need this low-level property for the invariant - (forall(i:nat{i < length hm.hash_map_slots}). index hm.hash_map_slots i == ListNil))) + (forall(i:nat{i < length hm.slots}). index hm.slots i == List_Nil))) #push-options "--z3rlimit 50 --fuel 1" -let hash_map_new_with_capacity_fwd_lem (t : Type0) (capacity : usize) +let hashMap_new_with_capacity_lem (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) = - let v = vec_new (list_t t) in + let v = alloc_vec_Vec_new (list_t t) in assert(length v = 0); - hash_map_allocate_slots_fwd_lem t v capacity; - begin match hash_map_allocate_slots_fwd t v capacity with + hashMap_allocate_slots_lem t v capacity; + begin match hashMap_allocate_slots t v capacity with | Fail _ -> assert(False) | Return v0 -> begin match usize_mul capacity max_load_dividend with @@ -582,9 +582,9 @@ let hash_map_new_with_capacity_fwd_lem (t : Type0) (capacity : usize) begin match usize_div i max_load_divisor with | Fail _ -> assert(False) | Return i0 -> - let hm = Mkhash_map_t 0 (max_load_dividend, max_load_divisor) i0 v0 in + let hm = MkhashMap_t 0 (max_load_dividend, max_load_divisor) i0 v0 in slots_t_all_nil_inv_lem v0; - slots_t_al_v_all_nil_is_empty_lem hm.hash_map_slots + slots_t_al_v_all_nil_is_empty_lem hm.slots end end end @@ -593,65 +593,65 @@ let hash_map_new_with_capacity_fwd_lem (t : Type0) (capacity : usize) (*** new *) /// [new] doesn't fail and returns an empty hash map -val hash_map_new_fwd_lem_aux (t : Type0) : +val hashMap_new_lem_aux (t : Type0) : Lemma (ensures ( - match hash_map_new_fwd t with + match hashMap_new t with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // The hash map has 0 values - hash_map_t_len_s hm = 0 /\ + hashMap_t_len_s hm = 0 /\ // It contains no bindings - (forall k. hash_map_t_find_s hm k == None))) + (forall k. hashMap_t_find_s hm k == None))) #push-options "--fuel 1" -let hash_map_new_fwd_lem_aux t = - hash_map_new_with_capacity_fwd_lem t 32 4 5; - match hash_map_new_with_capacity_fwd t 32 4 5 with +let hashMap_new_lem_aux t = + hashMap_new_with_capacity_lem t 32 4 5; + match hashMap_new_with_capacity t 32 4 5 with | Fail _ -> () | Return hm -> () #pop-options /// The lemma we reveal in the .fsti -let hash_map_new_fwd_lem t = hash_map_new_fwd_lem_aux t +let hashMap_new_lem t = hashMap_new_lem_aux t (*** clear *) /// [clear]: the loop doesn't fail and simply clears the slots starting at index i #push-options "--fuel 1" -let rec hash_map_clear_loop_fwd_back_lem - (t : Type0) (slots : vec (list_t t)) (i : usize) : +let rec hashMap_clear_loop_lem + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : Lemma (ensures ( - match hash_map_clear_loop_fwd_back t slots i with + match hashMap_clear_loop t slots i with | Fail _ -> False | Return slots' -> // The length is preserved length slots' == length slots /\ // The slots before i are left unchanged (forall (j:nat{j < i /\ j < length slots}). index slots' j == index slots j) /\ - // The slots after i are set to ListNil - (forall (j:nat{i <= j /\ j < length slots}). index slots' j == ListNil))) - (decreases (hash_map_clear_loop_decreases t slots i)) + // The slots after i are set to List_Nil + (forall (j:nat{i <= j /\ j < length slots}). index slots' j == List_Nil))) + (decreases (hashMap_clear_loop_decreases t slots i)) = - let i0 = vec_len (list_t t) slots in + let i0 = alloc_vec_Vec_len (list_t t) slots in let b = i < i0 in if b then - begin match vec_index_mut_back (list_t t) slots i ListNil with + begin match alloc_vec_Vec_update_usize slots i List_Nil with | Fail _ -> () | Return v -> begin match usize_add i 1 with | Fail _ -> () | Return i1 -> - hash_map_clear_loop_fwd_back_lem t v i1; - begin match hash_map_clear_loop_fwd_back t v i1 with + hashMap_clear_loop_lem t v i1; + begin match hashMap_clear_loop t v i1 with | Fail _ -> () | Return slots1 -> assert(length slots1 == length slots); - assert(forall (j:nat{i+1 <= j /\ j < length slots}). index slots1 j == ListNil); - assert(index slots1 i == ListNil) + assert(forall (j:nat{i+1 <= j /\ j < length slots}). index slots1 j == List_Nil); + assert(index slots1 i == List_Nil) end end end @@ -659,80 +659,80 @@ let rec hash_map_clear_loop_fwd_back_lem #pop-options /// [clear] doesn't fail and turns the hash map into an empty map -val hash_map_clear_fwd_back_lem_aux - (#t : Type0) (self : hash_map_t t) : +val hashMap_clear_lem_aux + (#t : Type0) (self : hashMap_t t) : Lemma - (requires (hash_map_t_base_inv self)) + (requires (hashMap_t_base_inv self)) (ensures ( - match hash_map_clear_fwd_back t self with + match hashMap_clear t self with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_base_inv hm /\ + hashMap_t_base_inv hm /\ // We preserved the parameters - hash_map_t_same_params hm self /\ + hashMap_t_same_params hm self /\ // The hash map has 0 values - hash_map_t_len_s hm = 0 /\ + hashMap_t_len_s hm = 0 /\ // It contains no bindings - (forall k. hash_map_t_find_s hm k == None))) + (forall k. hashMap_t_find_s hm k == None))) // Being lazy: fuel 1 helps a lot... #push-options "--fuel 1" -let hash_map_clear_fwd_back_lem_aux #t self = - let p = self.hash_map_max_load_factor in - let i = self.hash_map_max_load in - let v = self.hash_map_slots in - hash_map_clear_loop_fwd_back_lem t v 0; - begin match hash_map_clear_loop_fwd_back t v 0 with +let hashMap_clear_lem_aux #t self = + let p = self.max_load_factor in + let i = self.max_load in + let v = self.slots in + hashMap_clear_loop_lem t v 0; + begin match hashMap_clear_loop t v 0 with | Fail _ -> () | Return slots1 -> slots_t_al_v_all_nil_is_empty_lem slots1; - let hm1 = Mkhash_map_t 0 p i slots1 in - assert(hash_map_t_base_inv hm1); - assert(hash_map_t_inv hm1) + let hm1 = MkhashMap_t 0 p i slots1 in + assert(hashMap_t_base_inv hm1); + assert(hashMap_t_inv hm1) end #pop-options -let hash_map_clear_fwd_back_lem #t self = hash_map_clear_fwd_back_lem_aux #t self +let hashMap_clear_lem #t self = hashMap_clear_lem_aux #t self (*** len *) /// [len]: we link it to a non-failing function. /// Rk.: we might want to make an analysis to not use an error monad to translate /// functions which statically can't fail. -let hash_map_len_fwd_lem #t self = () +let hashMap_len_lem #t self = () (*** insert_in_list *) (**** insert_in_list'fwd *) -/// [insert_in_list_fwd]: returns true iff the key is not in the list (functional version) -val hash_map_insert_in_list_fwd_lem +/// [insert_in_list]: returns true iff the key is not in the list (functional version) +val hashMap_insert_in_list_lem (t : Type0) (key : usize) (value : t) (ls : list_t t) : Lemma (ensures ( - match hash_map_insert_in_list_fwd t key value ls with + match hashMap_insert_in_list t key value ls with | Fail _ -> False | Return b -> b <==> (slot_t_find_s key ls == None))) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) #push-options "--fuel 1" -let rec hash_map_insert_in_list_fwd_lem t key value ls = +let rec hashMap_insert_in_list_lem t key value ls = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_insert_in_list_fwd_lem t key value ls0; - match hash_map_insert_in_list_fwd t key value ls0 with + hashMap_insert_in_list_lem t key value ls0; + match hashMap_insert_in_list t key value ls0 with | Fail _ -> () | Return b0 -> () end - | ListNil -> + | List_Nil -> assert(list_t_v ls == []); assert_norm(find (same_key #t key) [] == None) end @@ -748,7 +748,7 @@ let rec hash_map_insert_in_list_fwd_lem t key value ls = /// We write a helper which "captures" what [insert_in_list] does. /// We then reason about this helper to prove the high-level properties we want /// (functional properties, preservation of invariants, etc.). -let hash_map_insert_in_list_s +let hashMap_insert_in_list_s (#t : Type0) (key : usize) (value : t) (ls : list (binding t)) : list (binding t) = // Check if there is already a binding for the key @@ -761,86 +761,86 @@ let hash_map_insert_in_list_s find_update (same_key key) ls (key,value) /// [insert_in_list]: if the key is not in the map, appends a new bindings (functional version) -val hash_map_insert_in_list_back_lem_append_s +val hashMap_insert_in_list_back_lem_append_s (t : Type0) (key : usize) (value : t) (ls : list_t t) : Lemma (requires ( slot_t_find_s key ls == None)) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> list_t_v ls' == list_t_v ls @ [(key,value)])) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) #push-options "--fuel 1" -let rec hash_map_insert_in_list_back_lem_append_s t key value ls = +let rec hashMap_insert_in_list_back_lem_append_s t key value ls = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_insert_in_list_back_lem_append_s t key value ls0; - match hash_map_insert_in_list_back t key value ls0 with + hashMap_insert_in_list_back_lem_append_s t key value ls0; + match hashMap_insert_in_list_back t key value ls0 with | Fail _ -> () | Return l -> () end - | ListNil -> () + | List_Nil -> () end #pop-options /// [insert_in_list]: if the key is in the map, we update the binding (functional version) -val hash_map_insert_in_list_back_lem_update_s +val hashMap_insert_in_list_back_lem_update_s (t : Type0) (key : usize) (value : t) (ls : list_t t) : Lemma (requires ( Some? (find (same_key key) (list_t_v ls)))) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> list_t_v ls' == find_update (same_key key) (list_t_v ls) (key,value))) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) #push-options "--fuel 1" -let rec hash_map_insert_in_list_back_lem_update_s t key value ls = +let rec hashMap_insert_in_list_back_lem_update_s t key value ls = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_insert_in_list_back_lem_update_s t key value ls0; - match hash_map_insert_in_list_back t key value ls0 with + hashMap_insert_in_list_back_lem_update_s t key value ls0; + match hashMap_insert_in_list_back t key value ls0 with | Fail _ -> () | Return l -> () end - | ListNil -> () + | List_Nil -> () end #pop-options /// Put everything together -val hash_map_insert_in_list_back_lem_s +val hashMap_insert_in_list_back_lem_s (t : Type0) (key : usize) (value : t) (ls : list_t t) : Lemma (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> - list_t_v ls' == hash_map_insert_in_list_s key value (list_t_v ls))) + list_t_v ls' == hashMap_insert_in_list_s key value (list_t_v ls))) -let hash_map_insert_in_list_back_lem_s t key value ls = +let hashMap_insert_in_list_back_lem_s t key value ls = match find (same_key key) (list_t_v ls) with - | None -> hash_map_insert_in_list_back_lem_append_s t key value ls - | Some _ -> hash_map_insert_in_list_back_lem_update_s t key value ls + | None -> hashMap_insert_in_list_back_lem_append_s t key value ls + | Some _ -> hashMap_insert_in_list_back_lem_update_s t key value ls (**** Invariants of insert_in_list_s *) /// Auxiliary lemmas -/// We work on [hash_map_insert_in_list_s], the "high-level" version of [insert_in_list'back]. +/// We work on [hashMap_insert_in_list_s], the "high-level" version of [insert_in_list'back]. /// /// Note that in F* we can't have recursive proofs inside of other proofs, contrary /// to Coq, which makes it a bit cumbersome to prove auxiliary results like the @@ -893,14 +893,14 @@ let rec slot_s_inv_not_find_append_end_inv_lem t len key value ls = #pop-options /// [insert_in_list]: if the key is not in the map, appends a new bindings -val hash_map_insert_in_list_s_lem_append +val hashMap_insert_in_list_s_lem_append (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list (binding t)) : Lemma (requires ( slot_s_inv len (hash_mod_key key len) ls /\ slot_s_find key ls == None)) (ensures ( - let ls' = hash_map_insert_in_list_s key value ls in + let ls' = hashMap_insert_in_list_s key value ls in ls' == ls @ [(key,value)] /\ // The invariant is preserved slot_s_inv len (hash_mod_key key len) ls' /\ @@ -909,20 +909,20 @@ val hash_map_insert_in_list_s_lem_append // The other bindings are preserved (forall k'. k' <> key ==> slot_s_find k' ls' == slot_s_find k' ls))) -let hash_map_insert_in_list_s_lem_append t len key value ls = +let hashMap_insert_in_list_s_lem_append t len key value ls = slot_s_inv_not_find_append_end_inv_lem t len key value ls /// [insert_in_list]: if the key is not in the map, appends a new bindings (quantifiers) /// Rk.: we don't use this lemma. /// TODO: remove? -val hash_map_insert_in_list_back_lem_append +val hashMap_insert_in_list_back_lem_append (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list_t t) : Lemma (requires ( slot_t_inv len (hash_mod_key key len) ls /\ slot_t_find_s key ls == None)) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> list_t_v ls' == list_t_v ls @ [(key,value)] /\ @@ -933,9 +933,9 @@ val hash_map_insert_in_list_back_lem_append // The other bindings are preserved (forall k'. k' <> key ==> slot_t_find_s k' ls' == slot_t_find_s k' ls))) -let hash_map_insert_in_list_back_lem_append t len key value ls = - hash_map_insert_in_list_back_lem_s t key value ls; - hash_map_insert_in_list_s_lem_append t len key value (list_t_v ls) +let hashMap_insert_in_list_back_lem_append t len key value ls = + hashMap_insert_in_list_back_lem_s t key value ls; + hashMap_insert_in_list_s_lem_append t len key value (list_t_v ls) (** Auxiliary lemmas: update case *) @@ -1013,14 +1013,14 @@ let rec slot_s_inv_find_append_end_inv_lem t len key value ls = #pop-options /// [insert_in_list]: if the key is in the map, update the bindings -val hash_map_insert_in_list_s_lem_update +val hashMap_insert_in_list_s_lem_update (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list (binding t)) : Lemma (requires ( slot_s_inv len (hash_mod_key key len) ls /\ Some? (slot_s_find key ls))) (ensures ( - let ls' = hash_map_insert_in_list_s key value ls in + let ls' = hashMap_insert_in_list_s key value ls in ls' == find_update (same_key key) ls (key,value) /\ // The invariant is preserved slot_s_inv len (hash_mod_key key len) ls' /\ @@ -1029,20 +1029,20 @@ val hash_map_insert_in_list_s_lem_update // The other bindings are preserved (forall k'. k' <> key ==> slot_s_find k' ls' == slot_s_find k' ls))) -let hash_map_insert_in_list_s_lem_update t len key value ls = +let hashMap_insert_in_list_s_lem_update t len key value ls = slot_s_inv_find_append_end_inv_lem t len key value ls /// [insert_in_list]: if the key is in the map, update the bindings /// TODO: not used: remove? -val hash_map_insert_in_list_back_lem_update +val hashMap_insert_in_list_back_lem_update (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list_t t) : Lemma (requires ( slot_t_inv len (hash_mod_key key len) ls /\ Some? (slot_t_find_s key ls))) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> let als = list_t_v ls in @@ -1054,20 +1054,20 @@ val hash_map_insert_in_list_back_lem_update // The other bindings are preserved (forall k'. k' <> key ==> slot_t_find_s k' ls' == slot_t_find_s k' ls))) -let hash_map_insert_in_list_back_lem_update t len key value ls = - hash_map_insert_in_list_back_lem_s t key value ls; - hash_map_insert_in_list_s_lem_update t len key value (list_t_v ls) +let hashMap_insert_in_list_back_lem_update t len key value ls = + hashMap_insert_in_list_back_lem_s t key value ls; + hashMap_insert_in_list_s_lem_update t len key value (list_t_v ls) (** Final lemmas about [insert_in_list] *) /// High-level version -val hash_map_insert_in_list_s_lem +val hashMap_insert_in_list_s_lem (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list (binding t)) : Lemma (requires ( slot_s_inv len (hash_mod_key key len) ls)) (ensures ( - let ls' = hash_map_insert_in_list_s key value ls in + let ls' = hashMap_insert_in_list_s key value ls in // The invariant is preserved slot_s_inv len (hash_mod_key key len) ls' /\ // [key] maps to [value] @@ -1079,22 +1079,22 @@ val hash_map_insert_in_list_s_lem | None -> length ls' = length ls + 1 | Some _ -> length ls' = length ls))) -let hash_map_insert_in_list_s_lem t len key value ls = +let hashMap_insert_in_list_s_lem t len key value ls = match slot_s_find key ls with | None -> assert_norm(length [(key,value)] = 1); - hash_map_insert_in_list_s_lem_append t len key value ls + hashMap_insert_in_list_s_lem_append t len key value ls | Some _ -> - hash_map_insert_in_list_s_lem_update t len key value ls + hashMap_insert_in_list_s_lem_update t len key value ls /// [insert_in_list] /// TODO: not used: remove? -val hash_map_insert_in_list_back_lem +val hashMap_insert_in_list_back_lem (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list_t t) : Lemma (requires (slot_t_inv len (hash_mod_key key len) ls)) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> // The invariant is preserved @@ -1111,127 +1111,127 @@ val hash_map_insert_in_list_back_lem | Some _ -> list_t_v ls' == find_update (same_key key) (list_t_v ls) (key,value) /\ list_t_len ls' = list_t_len ls))) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) -let hash_map_insert_in_list_back_lem t len key value ls = - hash_map_insert_in_list_back_lem_s t key value ls; - hash_map_insert_in_list_s_lem t len key value (list_t_v ls) +let hashMap_insert_in_list_back_lem t len key value ls = + hashMap_insert_in_list_back_lem_s t key value ls; + hashMap_insert_in_list_s_lem t len key value (list_t_v ls) (*** insert_no_resize *) (**** Refinement proof *) /// Same strategy as for [insert_in_list]: we introduce a high-level version of /// the function, and reason about it. -/// We work on [hash_map_s] (we use a higher-level view of the hash-map, but +/// We work on [hashMap_s] (we use a higher-level view of the hash-map, but /// not too high). /// A high-level version of insert, which doesn't check if the table is saturated -let hash_map_insert_no_fail_s - (#t : Type0) (hm : hash_map_s_nes t) +let hashMap_insert_no_fail_s + (#t : Type0) (hm : hashMap_s_nes t) (key : usize) (value : t) : - hash_map_s t = + hashMap_s t = let len = length hm in let i = hash_mod_key key len in let slot = index hm i in - let slot' = hash_map_insert_in_list_s key value slot in + let slot' = hashMap_insert_in_list_s key value slot in let hm' = list_update hm i slot' in hm' -// TODO: at some point I used hash_map_s_nes and it broke proofs...x -let hash_map_insert_no_resize_s - (#t : Type0) (hm : hash_map_s_nes t) +// TODO: at some point I used hashMap_s_nes and it broke proofs...x +let hashMap_insert_no_resize_s + (#t : Type0) (hm : hashMap_s_nes t) (key : usize) (value : t) : - result (hash_map_s t) = + result (hashMap_s t) = // Check if the table is saturated (too many entries, and we need to insert one) let num_entries = length (flatten hm) in - if None? (hash_map_s_find hm key) && num_entries = usize_max then Fail Failure - else Return (hash_map_insert_no_fail_s hm key value) + if None? (hashMap_s_find hm key) && num_entries = usize_max then Fail Failure + else Return (hashMap_insert_no_fail_s hm key value) -/// Prove that [hash_map_insert_no_resize_s] is refined by -/// [hash_map_insert_no_resize'fwd_back] -val hash_map_insert_no_resize_fwd_back_lem_s - (t : Type0) (self : hash_map_t t) (key : usize) (value : t) : +/// Prove that [hashMap_insert_no_resize_s] is refined by +/// [hashMap_insert_no_resize'fwd_back] +val hashMap_insert_no_resize_lem_s + (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : Lemma (requires ( - hash_map_t_base_inv self /\ - hash_map_s_len (hash_map_t_v self) = hash_map_t_len_s self)) + hashMap_t_base_inv self /\ + hashMap_s_len (hashMap_t_v self) = hashMap_t_len_s self)) (ensures ( begin - match hash_map_insert_no_resize_fwd_back t self key value, - hash_map_insert_no_resize_s (hash_map_t_v self) key value + match hashMap_insert_no_resize t self key value, + hashMap_insert_no_resize_s (hashMap_t_v self) key value with | Fail _, Fail _ -> True | Return hm, Return hm_v -> - hash_map_t_base_inv hm /\ - hash_map_t_same_params hm self /\ - hash_map_t_v hm == hm_v /\ - hash_map_s_len hm_v == hash_map_t_len_s hm + hashMap_t_base_inv hm /\ + hashMap_t_same_params hm self /\ + hashMap_t_v hm == hm_v /\ + hashMap_s_len hm_v == hashMap_t_len_s hm | _ -> False end)) -let hash_map_insert_no_resize_fwd_back_lem_s t self key value = - begin match hash_key_fwd key with +let hashMap_insert_no_resize_lem_s t self key value = + begin match hash_key key with | Fail _ -> () | Return i -> - let i0 = self.hash_map_num_entries in - let p = self.hash_map_max_load_factor in - let i1 = self.hash_map_max_load in - let v = self.hash_map_slots in - let i2 = vec_len (list_t t) v in + let i0 = self.num_entries in + let p = self.max_load_factor in + let i1 = self.max_load in + let v = self.slots in + let i2 = alloc_vec_Vec_len (list_t t) v in let len = length v in begin match usize_rem i i2 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_mut_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - // Checking that: list_t_v (index ...) == index (hash_map_t_v ...) ... - assert(list_t_v l == index (hash_map_t_v self) hash_mod); - hash_map_insert_in_list_fwd_lem t key value l; - match hash_map_insert_in_list_fwd t key value l with + // Checking that: list_t_v (index ...) == index (hashMap_t_v ...) ... + assert(list_t_v l == index (hashMap_t_v self) hash_mod); + hashMap_insert_in_list_lem t key value l; + match hashMap_insert_in_list t key value l with | Fail _ -> () | Return b -> assert(b = None? (slot_s_find key (list_t_v l))); - hash_map_insert_in_list_back_lem t len key value l; + hashMap_insert_in_list_back_lem t len key value l; if b then begin match usize_add i0 1 with | Fail _ -> () | Return i3 -> begin - match hash_map_insert_in_list_back t key value l with + match hashMap_insert_in_list_back t key value l with | Fail _ -> () | Return l0 -> - begin match vec_index_mut_back (list_t t) v hash_mod l0 with + begin match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () | Return v0 -> - let self_v = hash_map_t_v self in - let hm = Mkhash_map_t i3 p i1 v0 in - let hm_v = hash_map_t_v hm in + let self_v = hashMap_t_v self in + let hm = MkhashMap_t i3 p i1 v0 in + let hm_v = hashMap_t_v hm in assert(hm_v == list_update self_v hash_mod (list_t_v l0)); assert_norm(length [(key,value)] = 1); assert(length (list_t_v l0) = length (list_t_v l) + 1); length_flatten_update self_v hash_mod (list_t_v l0); - assert(hash_map_s_len hm_v = hash_map_t_len_s hm) + assert(hashMap_s_len hm_v = hashMap_t_len_s hm) end end end else begin - match hash_map_insert_in_list_back t key value l with + match hashMap_insert_in_list_back t key value l with | Fail _ -> () | Return l0 -> - begin match vec_index_mut_back (list_t t) v hash_mod l0 with + begin match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () | Return v0 -> - let self_v = hash_map_t_v self in - let hm = Mkhash_map_t i0 p i1 v0 in - let hm_v = hash_map_t_v hm in + let self_v = hashMap_t_v self in + let hm = MkhashMap_t i0 p i1 v0 in + let hm_v = hashMap_t_v hm in assert(hm_v == list_update self_v hash_mod (list_t_v l0)); assert(length (list_t_v l0) = length (list_t_v l)); length_flatten_update self_v hash_mod (list_t_v l0); - assert(hash_map_s_len hm_v = hash_map_t_len_s hm) + assert(hashMap_s_len hm_v = hashMap_t_len_s hm) end end end @@ -1241,108 +1241,108 @@ let hash_map_insert_no_resize_fwd_back_lem_s t self key value = (**** insert_{no_fail,no_resize}: invariants *) -let hash_map_s_updated_binding - (#t : Type0) (hm : hash_map_s_nes t) - (key : usize) (opt_value : option t) (hm' : hash_map_s_nes t) : Type0 = +let hashMap_s_updated_binding + (#t : Type0) (hm : hashMap_s_nes t) + (key : usize) (opt_value : option t) (hm' : hashMap_s_nes t) : Type0 = // [key] maps to [value] - hash_map_s_find hm' key == opt_value /\ + hashMap_s_find hm' key == opt_value /\ // The other bindings are preserved - (forall k'. k' <> key ==> hash_map_s_find hm' k' == hash_map_s_find hm k') + (forall k'. k' <> key ==> hashMap_s_find hm' k' == hashMap_s_find hm k') -let insert_post (#t : Type0) (hm : hash_map_s_nes t) - (key : usize) (value : t) (hm' : hash_map_s_nes t) : Type0 = +let insert_post (#t : Type0) (hm : hashMap_s_nes t) + (key : usize) (value : t) (hm' : hashMap_s_nes t) : Type0 = // The invariant is preserved - hash_map_s_inv hm' /\ + hashMap_s_inv hm' /\ // [key] maps to [value] and the other bindings are preserved - hash_map_s_updated_binding hm key (Some value) hm' /\ + hashMap_s_updated_binding hm key (Some value) hm' /\ // The length is incremented, iff we inserted a new key - (match hash_map_s_find hm key with - | None -> hash_map_s_len hm' = hash_map_s_len hm + 1 - | Some _ -> hash_map_s_len hm' = hash_map_s_len hm) + (match hashMap_s_find hm key with + | None -> hashMap_s_len hm' = hashMap_s_len hm + 1 + | Some _ -> hashMap_s_len hm' = hashMap_s_len hm) -val hash_map_insert_no_fail_s_lem - (#t : Type0) (hm : hash_map_s_nes t) +val hashMap_insert_no_fail_s_lem + (#t : Type0) (hm : hashMap_s_nes t) (key : usize) (value : t) : Lemma - (requires (hash_map_s_inv hm)) + (requires (hashMap_s_inv hm)) (ensures ( - let hm' = hash_map_insert_no_fail_s hm key value in + let hm' = hashMap_insert_no_fail_s hm key value in insert_post hm key value hm')) -let hash_map_insert_no_fail_s_lem #t hm key value = +let hashMap_insert_no_fail_s_lem #t hm key value = let len = length hm in let i = hash_mod_key key len in let slot = index hm i in - hash_map_insert_in_list_s_lem t len key value slot; - let slot' = hash_map_insert_in_list_s key value slot in + hashMap_insert_in_list_s_lem t len key value slot; + let slot' = hashMap_insert_in_list_s key value slot in length_flatten_update hm i slot' -val hash_map_insert_no_resize_s_lem - (#t : Type0) (hm : hash_map_s_nes t) +val hashMap_insert_no_resize_s_lem + (#t : Type0) (hm : hashMap_s_nes t) (key : usize) (value : t) : Lemma - (requires (hash_map_s_inv hm)) + (requires (hashMap_s_inv hm)) (ensures ( - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail _ -> // Can fail only if we need to create a new binding in // an already saturated map - hash_map_s_len hm = usize_max /\ - None? (hash_map_s_find hm key) + hashMap_s_len hm = usize_max /\ + None? (hashMap_s_find hm key) | Return hm' -> insert_post hm key value hm')) -let hash_map_insert_no_resize_s_lem #t hm key value = +let hashMap_insert_no_resize_s_lem #t hm key value = let num_entries = length (flatten hm) in - if None? (hash_map_s_find hm key) && num_entries = usize_max then () - else hash_map_insert_no_fail_s_lem hm key value + if None? (hashMap_s_find hm key) && num_entries = usize_max then () + else hashMap_insert_no_fail_s_lem hm key value (**** find after insert *) /// Lemmas about what happens if we call [find] after an insertion -val hash_map_insert_no_resize_s_get_same_lem - (#t : Type0) (hm : hash_map_s t) +val hashMap_insert_no_resize_s_get_same_lem + (#t : Type0) (hm : hashMap_s t) (key : usize) (value : t) : - Lemma (requires (hash_map_s_inv hm)) + Lemma (requires (hashMap_s_inv hm)) (ensures ( - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail _ -> True | Return hm' -> - hash_map_s_find hm' key == Some value)) + hashMap_s_find hm' key == Some value)) -let hash_map_insert_no_resize_s_get_same_lem #t hm key value = +let hashMap_insert_no_resize_s_get_same_lem #t hm key value = let num_entries = length (flatten hm) in - if None? (hash_map_s_find hm key) && num_entries = usize_max then () + if None? (hashMap_s_find hm key) && num_entries = usize_max then () else begin - let hm' = Return?.v (hash_map_insert_no_resize_s hm key value) in + let hm' = Return?.v (hashMap_insert_no_resize_s hm key value) in let len = length hm in let i = hash_mod_key key len in let slot = index hm i in - hash_map_insert_in_list_s_lem t len key value slot + hashMap_insert_in_list_s_lem t len key value slot end -val hash_map_insert_no_resize_s_get_diff_lem - (#t : Type0) (hm : hash_map_s t) +val hashMap_insert_no_resize_s_get_diff_lem + (#t : Type0) (hm : hashMap_s t) (key : usize) (value : t) (key' : usize{key' <> key}) : - Lemma (requires (hash_map_s_inv hm)) + Lemma (requires (hashMap_s_inv hm)) (ensures ( - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail _ -> True | Return hm' -> - hash_map_s_find hm' key' == hash_map_s_find hm key')) + hashMap_s_find hm' key' == hashMap_s_find hm key')) -let hash_map_insert_no_resize_s_get_diff_lem #t hm key value key' = +let hashMap_insert_no_resize_s_get_diff_lem #t hm key value key' = let num_entries = length (flatten hm) in - if None? (hash_map_s_find hm key) && num_entries = usize_max then () + if None? (hashMap_s_find hm key) && num_entries = usize_max then () else begin - let hm' = Return?.v (hash_map_insert_no_resize_s hm key value) in + let hm' = Return?.v (hashMap_insert_no_resize_s hm key value) in let len = length hm in let i = hash_mod_key key len in let slot = index hm i in - hash_map_insert_in_list_s_lem t len key value slot; + hashMap_insert_in_list_s_lem t len key value slot; let i' = hash_mod_key key' len in if i <> i' then () else @@ -1354,116 +1354,116 @@ let hash_map_insert_no_resize_s_get_diff_lem #t hm key value key' = (*** move_elements_from_list *) -/// Having a great time here: if we use `result (hash_map_s_res t)` as the -/// return type for [hash_map_move_elements_from_list_s] instead of having this -/// awkward match, the proof of [hash_map_move_elements_fwd_back_lem_refin] fails. +/// Having a great time here: if we use `result (hashMap_s_res t)` as the +/// return type for [hashMap_move_elements_from_list_s] instead of having this +/// awkward match, the proof of [hashMap_move_elements_lem_refin] fails. /// I guess it comes from F*'s poor subtyping. -/// Followingly, I'm not taking any chance and using [result_hash_map_s] +/// Followingly, I'm not taking any chance and using [result_hashMap_s] /// everywhere. -type result_hash_map_s_nes (t : Type0) : Type0 = - res:result (hash_map_s t) { +type result_hashMap_s_nes (t : Type0) : Type0 = + res:result (hashMap_s t) { match res with | Fail _ -> True | Return hm -> is_pos_usize (length hm) } -let rec hash_map_move_elements_from_list_s - (#t : Type0) (hm : hash_map_s_nes t) +let rec hashMap_move_elements_from_list_s + (#t : Type0) (hm : hashMap_s_nes t) (ls : slot_s t) : - // Do *NOT* use `result (hash_map_s t)` - Tot (result_hash_map_s_nes t) + // Do *NOT* use `result (hashMap_s t)` + Tot (result_hashMap_s_nes t) (decreases ls) = match ls with | [] -> Return hm | (key, value) :: ls' -> - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail e -> Fail e | Return hm' -> - hash_map_move_elements_from_list_s hm' ls' + hashMap_move_elements_from_list_s hm' ls' /// Refinement lemma -val hash_map_move_elements_from_list_fwd_back_lem - (t : Type0) (ntable : hash_map_t_nes t) (ls : list_t t) : - Lemma (requires (hash_map_t_base_inv ntable)) +val hashMap_move_elements_from_list_lem + (t : Type0) (ntable : hashMap_t_nes t) (ls : list_t t) : + Lemma (requires (hashMap_t_base_inv ntable)) (ensures ( - match hash_map_move_elements_from_list_fwd_back t ntable ls, - hash_map_move_elements_from_list_s (hash_map_t_v ntable) (slot_t_v ls) + match hashMap_move_elements_from_list t ntable ls, + hashMap_move_elements_from_list_s (hashMap_t_v ntable) (slot_t_v ls) with | Fail _, Fail _ -> True | Return hm', Return hm_v -> - hash_map_t_base_inv hm' /\ - hash_map_t_v hm' == hm_v /\ - hash_map_t_same_params hm' ntable + hashMap_t_base_inv hm' /\ + hashMap_t_v hm' == hm_v /\ + hashMap_t_same_params hm' ntable | _ -> False)) - (decreases (hash_map_move_elements_from_list_loop_decreases t ntable ls)) + (decreases (hashMap_move_elements_from_list_loop_decreases t ntable ls)) #push-options "--fuel 1" -let rec hash_map_move_elements_from_list_fwd_back_lem t ntable ls = +let rec hashMap_move_elements_from_list_lem t ntable ls = begin match ls with - | ListCons k v tl -> + | List_Cons k v tl -> assert(list_t_v ls == (k, v) :: list_t_v tl); let ls_v = list_t_v ls in let (_,_) :: tl_v = ls_v in - hash_map_insert_no_resize_fwd_back_lem_s t ntable k v; - begin match hash_map_insert_no_resize_fwd_back t ntable k v with + hashMap_insert_no_resize_lem_s t ntable k v; + begin match hashMap_insert_no_resize t ntable k v with | Fail _ -> () | Return h -> - let h_v = Return?.v (hash_map_insert_no_resize_s (hash_map_t_v ntable) k v) in - assert(hash_map_t_v h == h_v); - hash_map_move_elements_from_list_fwd_back_lem t h tl; - begin match hash_map_move_elements_from_list_fwd_back t h tl with + let h_v = Return?.v (hashMap_insert_no_resize_s (hashMap_t_v ntable) k v) in + assert(hashMap_t_v h == h_v); + hashMap_move_elements_from_list_lem t h tl; + begin match hashMap_move_elements_from_list t h tl with | Fail _ -> () | Return h0 -> () end end - | ListNil -> () + | List_Nil -> () end #pop-options (*** move_elements *) (**** move_elements: refinement 0 *) -/// The proof for [hash_map_move_elements_fwd_back_lem_refin] broke so many times +/// The proof for [hashMap_move_elements_lem_refin] broke so many times /// (while it is supposed to be super simple!) that we decided to add one refinement /// level, to really do things step by step... /// Doing this refinement layer made me notice that maybe the problem came from -/// the fact that at some point we have to prove `list_t_v ListNil == []`: I +/// the fact that at some point we have to prove `list_t_v List_Nil == []`: I /// added the corresponding assert to help Z3 and everything became stable. /// I finally didn't use this "simple" refinement lemma, but I still keep it here -/// because it allows for easy comparisons with [hash_map_move_elements_s]. +/// because it allows for easy comparisons with [hashMap_move_elements_s]. -/// [hash_map_move_elements_fwd] refines this function, which is actually almost +/// [hashMap_move_elements] refines this function, which is actually almost /// the same (just a little bit shorter and cleaner, and has a pre). /// /// The way I wrote the high-level model is the following: -/// - I copy-pasted the definition of [hash_map_move_elements_fwd], wrote the -/// signature which links this new definition to [hash_map_move_elements_fwd] and +/// - I copy-pasted the definition of [hashMap_move_elements], wrote the +/// signature which links this new definition to [hashMap_move_elements] and /// checked that the proof passed /// - I gradually simplified it, while making sure the proof still passes #push-options "--fuel 1" -let rec hash_map_move_elements_s_simpl - (t : Type0) (ntable : hash_map_t t) - (slots : vec (list_t t)) +let rec hashMap_move_elements_s_simpl + (t : Type0) (ntable : hashMap_t t) + (slots : alloc_vec_Vec (list_t t)) (i : usize{i <= length slots /\ length slots <= usize_max}) : - Pure (result ((hash_map_t t) & (vec (list_t t)))) + Pure (result ((hashMap_t t) & (alloc_vec_Vec (list_t t)))) (requires (True)) (ensures (fun res -> - match res, hash_map_move_elements_fwd_back t ntable slots i with + match res, hashMap_move_elements t ntable slots i with | Fail _, Fail _ -> True | Return (ntable1, slots1), Return (ntable2, slots2) -> ntable1 == ntable2 /\ slots1 == slots2 | _ -> False)) - (decreases (hash_map_move_elements_loop_decreases t ntable slots i)) + (decreases (hashMap_move_elements_loop_decreases t ntable slots i)) = if i < length slots then let slot = index slots i in - begin match hash_map_move_elements_from_list_fwd_back t ntable slot with + begin match hashMap_move_elements_from_list t ntable slot with | Fail e -> Fail e | Return hm' -> - let slots' = list_update slots i ListNil in - hash_map_move_elements_s_simpl t hm' slots' (i+1) + let slots' = list_update slots i List_Nil in + hashMap_move_elements_s_simpl t hm' slots' (i+1) end else Return (ntable, slots) #pop-options @@ -1476,71 +1476,71 @@ let rec hash_map_move_elements_s_simpl // Note that we ignore the returned slots (we thus don't return a pair: // only the new hash map in which we moved the elements from the slots): // this returned value is not used. -let rec hash_map_move_elements_s - (#t : Type0) (hm : hash_map_s_nes t) +let rec hashMap_move_elements_s + (#t : Type0) (hm : hashMap_s_nes t) (slots : slots_s t) (i : usize{i <= length slots /\ length slots <= usize_max}) : - Tot (result_hash_map_s_nes t) + Tot (result_hashMap_s_nes t) (decreases (length slots - i)) = let len = length slots in if i < len then begin let slot = index slots i in - match hash_map_move_elements_from_list_s hm slot with + match hashMap_move_elements_from_list_s hm slot with | Fail e -> Fail e | Return hm' -> let slots' = list_update slots i [] in - hash_map_move_elements_s hm' slots' (i+1) + hashMap_move_elements_s hm' slots' (i+1) end else Return hm -val hash_map_move_elements_fwd_back_lem_refin - (t : Type0) (ntable : hash_map_t t) - (slots : vec (list_t t)) (i : usize{i <= length slots}) : +val hashMap_move_elements_lem_refin + (t : Type0) (ntable : hashMap_t t) + (slots : alloc_vec_Vec (list_t t)) (i : usize{i <= length slots}) : Lemma (requires ( - hash_map_t_base_inv ntable)) + hashMap_t_base_inv ntable)) (ensures ( - match hash_map_move_elements_fwd_back t ntable slots i, - hash_map_move_elements_s (hash_map_t_v ntable) (slots_t_v slots) i + match hashMap_move_elements t ntable slots i, + hashMap_move_elements_s (hashMap_t_v ntable) (slots_t_v slots) i with | Fail _, Fail _ -> True // We will prove later that this is not possible | Return (ntable', _), Return ntable'_v -> - hash_map_t_base_inv ntable' /\ - hash_map_t_v ntable' == ntable'_v /\ - hash_map_t_same_params ntable' ntable + hashMap_t_base_inv ntable' /\ + hashMap_t_v ntable' == ntable'_v /\ + hashMap_t_same_params ntable' ntable | _ -> False)) (decreases (length slots - i)) #restart-solver #push-options "--fuel 1" -let rec hash_map_move_elements_fwd_back_lem_refin t ntable slots i = - assert(hash_map_t_base_inv ntable); - let i0 = vec_len (list_t t) slots in +let rec hashMap_move_elements_lem_refin t ntable slots i = + assert(hashMap_t_base_inv ntable); + let i0 = alloc_vec_Vec_len (list_t t) slots in let b = i < i0 in if b then - begin match vec_index_mut_fwd (list_t t) slots i with + begin match alloc_vec_Vec_index_usize slots i with | Fail _ -> () | Return l -> - let l0 = mem_replace_fwd (list_t t) l ListNil in + let l0 = core_mem_replace (list_t t) l List_Nil in assert(l0 == l); - hash_map_move_elements_from_list_fwd_back_lem t ntable l0; - begin match hash_map_move_elements_from_list_fwd_back t ntable l0 with + hashMap_move_elements_from_list_lem t ntable l0; + begin match hashMap_move_elements_from_list t ntable l0 with | Fail _ -> () | Return h -> - let l1 = mem_replace_back (list_t t) l ListNil in - assert(l1 == ListNil); - assert(slot_t_v #t ListNil == []); // THIS IS IMPORTANT - begin match vec_index_mut_back (list_t t) slots i l1 with + let l1 = core_mem_replace_back (list_t t) l List_Nil in + assert(l1 == List_Nil); + assert(slot_t_v #t List_Nil == []); // THIS IS IMPORTANT + begin match alloc_vec_Vec_update_usize slots i l1 with | Fail _ -> () | Return v -> begin match usize_add i 1 with | Fail _ -> () | Return i1 -> - hash_map_move_elements_fwd_back_lem_refin t h v i1; - begin match hash_map_move_elements_fwd_back t h v i1 with + hashMap_move_elements_lem_refin t h v i1; + begin match hashMap_move_elements t h v i1 with | Fail _ -> - assert(Fail? (hash_map_move_elements_fwd_back t ntable slots i)); + assert(Fail? (hashMap_move_elements t ntable slots i)); () | Return (ntable', v0) -> () end @@ -1560,19 +1560,19 @@ let rec hash_map_move_elements_fwd_back_lem_refin t ntable slots i = /// [ntable] is the hash map to which we move the elements /// [slots] is the current hash map, from which we remove the elements, and seen /// as a "flat" associative list (and not a list of lists) -/// This is actually exactly [hash_map_move_elements_from_list_s]... -let rec hash_map_move_elements_s_flat - (#t : Type0) (ntable : hash_map_s_nes t) +/// This is actually exactly [hashMap_move_elements_from_list_s]... +let rec hashMap_move_elements_s_flat + (#t : Type0) (ntable : hashMap_s_nes t) (slots : assoc_list t) : - Tot (result_hash_map_s_nes t) + Tot (result_hashMap_s_nes t) (decreases slots) = match slots with | [] -> Return ntable | (k,v) :: slots' -> - match hash_map_insert_no_resize_s ntable k v with + match hashMap_insert_no_resize_s ntable k v with | Fail e -> Fail e | Return ntable' -> - hash_map_move_elements_s_flat ntable' slots' + hashMap_move_elements_s_flat ntable' slots' /// The refinment lemmas /// First, auxiliary helpers. @@ -1656,42 +1656,42 @@ let rec flatten_nil_prefix_as_flatten_i #a l i = /// The proof is trivial, the functions are the same. /// Just keeping two definitions to allow changes... -val hash_map_move_elements_from_list_s_as_flat_lem - (#t : Type0) (hm : hash_map_s_nes t) +val hashMap_move_elements_from_list_s_as_flat_lem + (#t : Type0) (hm : hashMap_s_nes t) (ls : slot_s t) : Lemma (ensures ( - hash_map_move_elements_from_list_s hm ls == - hash_map_move_elements_s_flat hm ls)) + hashMap_move_elements_from_list_s hm ls == + hashMap_move_elements_s_flat hm ls)) (decreases ls) #push-options "--fuel 1" -let rec hash_map_move_elements_from_list_s_as_flat_lem #t hm ls = +let rec hashMap_move_elements_from_list_s_as_flat_lem #t hm ls = match ls with | [] -> () | (key, value) :: ls' -> - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail _ -> () | Return hm' -> - hash_map_move_elements_from_list_s_as_flat_lem hm' ls' + hashMap_move_elements_from_list_s_as_flat_lem hm' ls' #pop-options -/// Composition of two calls to [hash_map_move_elements_s_flat] -let hash_map_move_elements_s_flat_comp - (#t : Type0) (hm : hash_map_s_nes t) (slot0 slot1 : slot_s t) : - Tot (result_hash_map_s_nes t) = - match hash_map_move_elements_s_flat hm slot0 with +/// Composition of two calls to [hashMap_move_elements_s_flat] +let hashMap_move_elements_s_flat_comp + (#t : Type0) (hm : hashMap_s_nes t) (slot0 slot1 : slot_s t) : + Tot (result_hashMap_s_nes t) = + match hashMap_move_elements_s_flat hm slot0 with | Fail e -> Fail e - | Return hm1 -> hash_map_move_elements_s_flat hm1 slot1 + | Return hm1 -> hashMap_move_elements_s_flat hm1 slot1 /// High-level desc: /// move_elements (move_elements hm slot0) slo1 == move_elements hm (slot0 @ slot1) -val hash_map_move_elements_s_flat_append_lem - (#t : Type0) (hm : hash_map_s_nes t) (slot0 slot1 : slot_s t) : +val hashMap_move_elements_s_flat_append_lem + (#t : Type0) (hm : hashMap_s_nes t) (slot0 slot1 : slot_s t) : Lemma (ensures ( - match hash_map_move_elements_s_flat_comp hm slot0 slot1, - hash_map_move_elements_s_flat hm (slot0 @ slot1) + match hashMap_move_elements_s_flat_comp hm slot0 slot1, + hashMap_move_elements_s_flat hm (slot0 @ slot1) with | Fail _, Fail _ -> True | Return hm1, Return hm2 -> hm1 == hm2 @@ -1699,14 +1699,14 @@ val hash_map_move_elements_s_flat_append_lem (decreases (slot0)) #push-options "--fuel 1" -let rec hash_map_move_elements_s_flat_append_lem #t hm slot0 slot1 = +let rec hashMap_move_elements_s_flat_append_lem #t hm slot0 slot1 = match slot0 with | [] -> () | (k,v) :: slot0' -> - match hash_map_insert_no_resize_s hm k v with + match hashMap_insert_no_resize_s hm k v with | Fail _ -> () | Return hm' -> - hash_map_move_elements_s_flat_append_lem hm' slot0' slot1 + hashMap_move_elements_s_flat_append_lem hm' slot0' slot1 #pop-options val flatten_i_same_suffix (#a : Type) (l0 l1 : list (list a)) (i : nat) : @@ -1726,16 +1726,16 @@ let rec flatten_i_same_suffix #a l0 l1 i = #pop-options /// Refinement lemma: -/// [hash_map_move_elements_s] refines [hash_map_move_elements_s_flat] +/// [hashMap_move_elements_s] refines [hashMap_move_elements_s_flat] /// (actually the functions are equal on all inputs). -val hash_map_move_elements_s_lem_refin_flat - (#t : Type0) (hm : hash_map_s_nes t) +val hashMap_move_elements_s_lem_refin_flat + (#t : Type0) (hm : hashMap_s_nes t) (slots : slots_s t) (i : nat{i <= length slots /\ length slots <= usize_max}) : Lemma (ensures ( - match hash_map_move_elements_s hm slots i, - hash_map_move_elements_s_flat hm (flatten_i slots i) + match hashMap_move_elements_s hm slots i, + hashMap_move_elements_s_flat hm (flatten_i slots i) with | Fail _, Fail _ -> True | Return hm, Return hm' -> hm == hm' @@ -1743,22 +1743,22 @@ val hash_map_move_elements_s_lem_refin_flat (decreases (length slots - i)) #push-options "--fuel 1" -let rec hash_map_move_elements_s_lem_refin_flat #t hm slots i = +let rec hashMap_move_elements_s_lem_refin_flat #t hm slots i = let len = length slots in if i < len then begin let slot = index slots i in - hash_map_move_elements_from_list_s_as_flat_lem hm slot; - match hash_map_move_elements_from_list_s hm slot with + hashMap_move_elements_from_list_s_as_flat_lem hm slot; + match hashMap_move_elements_from_list_s hm slot with | Fail _ -> assert(flatten_i slots i == slot @ flatten_i slots (i+1)); - hash_map_move_elements_s_flat_append_lem hm slot (flatten_i slots (i+1)); - assert(Fail? (hash_map_move_elements_s_flat hm (flatten_i slots i))) + hashMap_move_elements_s_flat_append_lem hm slot (flatten_i slots (i+1)); + assert(Fail? (hashMap_move_elements_s_flat hm (flatten_i slots i))) | Return hm' -> let slots' = list_update slots i [] in flatten_i_same_suffix slots slots' (i+1); - hash_map_move_elements_s_lem_refin_flat hm' slots' (i+1); - hash_map_move_elements_s_flat_append_lem hm slot (flatten_i slots' (i+1)); + hashMap_move_elements_s_lem_refin_flat hm' slots' (i+1); + hashMap_move_elements_s_flat_append_lem hm slot (flatten_i slots' (i+1)); () end else () @@ -1769,21 +1769,21 @@ let assoc_list_inv (#t : Type0) (al : assoc_list t) : Type0 = pairwise_rel binding_neq al let disjoint_hm_al_on_key - (#t : Type0) (hm : hash_map_s_nes t) (al : assoc_list t) (k : key) : Type0 = - match hash_map_s_find hm k, assoc_list_find k al with + (#t : Type0) (hm : hashMap_s_nes t) (al : assoc_list t) (k : key) : Type0 = + match hashMap_s_find hm k, assoc_list_find k al with | Some _, None | None, Some _ | None, None -> True | Some _, Some _ -> False /// Playing a dangerous game here: using forall quantifiers -let disjoint_hm_al (#t : Type0) (hm : hash_map_s_nes t) (al : assoc_list t) : Type0 = +let disjoint_hm_al (#t : Type0) (hm : hashMap_s_nes t) (al : assoc_list t) : Type0 = forall (k:key). disjoint_hm_al_on_key hm al k let find_in_union_hm_al - (#t : Type0) (hm : hash_map_s_nes t) (al : assoc_list t) (k : key) : + (#t : Type0) (hm : hashMap_s_nes t) (al : assoc_list t) (k : key) : option t = - match hash_map_s_find hm k with + match hashMap_s_find hm k with | Some b -> Some b | None -> assoc_list_find k al @@ -1799,58 +1799,58 @@ let rec for_all_binding_neq_find_lem #t k v al = | b :: al' -> for_all_binding_neq_find_lem k v al' #pop-options -val hash_map_move_elements_s_flat_lem - (#t : Type0) (hm : hash_map_s_nes t) (al : assoc_list t) : +val hashMap_move_elements_s_flat_lem + (#t : Type0) (hm : hashMap_s_nes t) (al : assoc_list t) : Lemma (requires ( // Invariants - hash_map_s_inv hm /\ + hashMap_s_inv hm /\ assoc_list_inv al /\ // The two are disjoint disjoint_hm_al hm al /\ // We can add all the elements to the hashmap - hash_map_s_len hm + length al <= usize_max)) + hashMap_s_len hm + length al <= usize_max)) (ensures ( - match hash_map_move_elements_s_flat hm al with + match hashMap_move_elements_s_flat hm al with | Fail _ -> False // We can't fail | Return hm' -> // The invariant is preserved - hash_map_s_inv hm' /\ + hashMap_s_inv hm' /\ // The new hash map is the union of the two maps - (forall (k:key). hash_map_s_find hm' k == find_in_union_hm_al hm al k) /\ - hash_map_s_len hm' = hash_map_s_len hm + length al)) + (forall (k:key). hashMap_s_find hm' k == find_in_union_hm_al hm al k) /\ + hashMap_s_len hm' = hashMap_s_len hm + length al)) (decreases al) #restart-solver #push-options "--z3rlimit 200 --fuel 1" -let rec hash_map_move_elements_s_flat_lem #t hm al = +let rec hashMap_move_elements_s_flat_lem #t hm al = match al with | [] -> () | (k,v) :: al' -> - hash_map_insert_no_resize_s_lem hm k v; - match hash_map_insert_no_resize_s hm k v with + hashMap_insert_no_resize_s_lem hm k v; + match hashMap_insert_no_resize_s hm k v with | Fail _ -> () | Return hm' -> - assert(hash_map_s_inv hm'); + assert(hashMap_s_inv hm'); assert(assoc_list_inv al'); let disjoint_lem (k' : key) : Lemma (disjoint_hm_al_on_key hm' al' k') [SMTPat (disjoint_hm_al_on_key hm' al' k')] = if k' = k then begin - assert(hash_map_s_find hm' k' == Some v); + assert(hashMap_s_find hm' k' == Some v); for_all_binding_neq_find_lem k v al'; assert(assoc_list_find k' al' == None) end else begin - assert(hash_map_s_find hm' k' == hash_map_s_find hm k'); + assert(hashMap_s_find hm' k' == hashMap_s_find hm k'); assert(assoc_list_find k' al' == assoc_list_find k' al) end in assert(disjoint_hm_al hm' al'); - assert(hash_map_s_len hm' + length al' <= usize_max); - hash_map_move_elements_s_flat_lem hm' al' + assert(hashMap_s_len hm' + length al' <= usize_max); + hashMap_move_elements_s_flat_lem hm' al' #pop-options /// We need to prove that the invariants on the "low-level" representations of @@ -1866,18 +1866,18 @@ let slots_t_inv_implies_slots_s_inv #t slots = // Problem is: I can never really predict for sure with F*... () -val hash_map_t_base_inv_implies_hash_map_s_inv - (#t : Type0) (hm : hash_map_t t) : - Lemma (requires (hash_map_t_base_inv hm)) - (ensures (hash_map_s_inv (hash_map_t_v hm))) +val hashMap_t_base_inv_implies_hashMap_s_inv + (#t : Type0) (hm : hashMap_t t) : + Lemma (requires (hashMap_t_base_inv hm)) + (ensures (hashMap_s_inv (hashMap_t_v hm))) -let hash_map_t_base_inv_implies_hash_map_s_inv #t hm = () // same as previous +let hashMap_t_base_inv_implies_hashMap_s_inv #t hm = () // same as previous /// Introducing a "partial" version of the hash map invariant, which operates on /// a suffix of the hash map. -let partial_hash_map_s_inv +let partial_hashMap_s_inv (#t : Type0) (len : usize{len > 0}) (offset : usize) - (hm : hash_map_s t{offset + length hm <= usize_max}) : Type0 = + (hm : hashMap_s t{offset + length hm <= usize_max}) : Type0 = forall(i:nat{i < length hm}). {:pattern index hm i} slot_s_inv len (offset + i) (index hm i) /// Auxiliary lemma. @@ -1887,13 +1887,13 @@ val binding_in_previous_slot_implies_neq (#t : Type0) (len : usize{len > 0}) (i : usize) (b : binding t) (offset : usize{i < offset}) - (slots : hash_map_s t{offset + length slots <= usize_max}) : + (slots : hashMap_s t{offset + length slots <= usize_max}) : Lemma (requires ( // The binding comes from a slot not in [slots] hash_mod_key (fst b) len = i /\ // The slots are the well-formed suffix of a hash map - partial_hash_map_s_inv len offset slots)) + partial_hashMap_s_inv len offset slots)) (ensures ( for_all (binding_neq b) (flatten slots))) (decreases slots) @@ -1924,17 +1924,17 @@ let rec binding_in_previous_slot_implies_neq #t len i b offset slots = for_all_append (binding_neq b) s (flatten slots') #pop-options -val partial_hash_map_s_inv_implies_assoc_list_lem +val partial_hashMap_s_inv_implies_assoc_list_lem (#t : Type0) (len : usize{len > 0}) (offset : usize) - (hm : hash_map_s t{offset + length hm <= usize_max}) : + (hm : hashMap_s t{offset + length hm <= usize_max}) : Lemma (requires ( - partial_hash_map_s_inv len offset hm)) + partial_hashMap_s_inv len offset hm)) (ensures (assoc_list_inv (flatten hm))) (decreases (length hm + length (flatten hm))) #push-options "--fuel 1" -let rec partial_hash_map_s_inv_implies_assoc_list_lem #t len offset hm = +let rec partial_hashMap_s_inv_implies_assoc_list_lem #t len offset hm = match hm with | [] -> () | slot :: hm' -> @@ -1943,8 +1943,8 @@ let rec partial_hash_map_s_inv_implies_assoc_list_lem #t len offset hm = match slot with | [] -> assert(flatten hm == flatten hm'); - assert(partial_hash_map_s_inv len (offset+1) hm'); // Triggers instantiations - partial_hash_map_s_inv_implies_assoc_list_lem len (offset+1) hm' + assert(partial_hashMap_s_inv len (offset+1) hm'); // Triggers instantiations + partial_hashMap_s_inv_implies_assoc_list_lem len (offset+1) hm' | x :: slot' -> assert(flatten (slot' :: hm') == slot' @ flatten hm'); let hm'' = slot' :: hm' in @@ -1953,45 +1953,45 @@ let rec partial_hash_map_s_inv_implies_assoc_list_lem #t len offset hm = assert(index hm 0 == slot); // Triggers instantiations assert(slot_s_inv len offset slot); assert(slot_s_inv len offset slot'); - assert(partial_hash_map_s_inv len offset hm''); - partial_hash_map_s_inv_implies_assoc_list_lem len offset (slot' :: hm'); + assert(partial_hashMap_s_inv len offset hm''); + partial_hashMap_s_inv_implies_assoc_list_lem len offset (slot' :: hm'); // Proving that the key in `x` is different from all the other keys in // the flattened map assert(for_all (binding_neq x) slot'); for_all_append (binding_neq x) slot' (flatten hm'); - assert(partial_hash_map_s_inv len (offset+1) hm'); + assert(partial_hashMap_s_inv len (offset+1) hm'); binding_in_previous_slot_implies_neq #t len offset x (offset+1) hm'; assert(for_all (binding_neq x) (flatten hm')); assert(for_all (binding_neq x) (flatten (slot' :: hm'))) #pop-options -val hash_map_s_inv_implies_assoc_list_lem - (#t : Type0) (hm : hash_map_s t) : - Lemma (requires (hash_map_s_inv hm)) +val hashMap_s_inv_implies_assoc_list_lem + (#t : Type0) (hm : hashMap_s t) : + Lemma (requires (hashMap_s_inv hm)) (ensures (assoc_list_inv (flatten hm))) -let hash_map_s_inv_implies_assoc_list_lem #t hm = - partial_hash_map_s_inv_implies_assoc_list_lem (length hm) 0 hm +let hashMap_s_inv_implies_assoc_list_lem #t hm = + partial_hashMap_s_inv_implies_assoc_list_lem (length hm) 0 hm -val hash_map_t_base_inv_implies_assoc_list_lem - (#t : Type0) (hm : hash_map_t t): - Lemma (requires (hash_map_t_base_inv hm)) - (ensures (assoc_list_inv (hash_map_t_al_v hm))) +val hashMap_t_base_inv_implies_assoc_list_lem + (#t : Type0) (hm : hashMap_t t): + Lemma (requires (hashMap_t_base_inv hm)) + (ensures (assoc_list_inv (hashMap_t_al_v hm))) -let hash_map_t_base_inv_implies_assoc_list_lem #t hm = - hash_map_s_inv_implies_assoc_list_lem (hash_map_t_v hm) +let hashMap_t_base_inv_implies_assoc_list_lem #t hm = + hashMap_s_inv_implies_assoc_list_lem (hashMap_t_v hm) /// For some reason, we can't write the below [forall] directly in the [ensures] /// clause of the next lemma: it makes Z3 fails even with a huge rlimit. /// I have no idea what's going on. -let hash_map_is_assoc_list - (#t : Type0) (ntable : hash_map_t t{length ntable.hash_map_slots > 0}) +let hashMap_is_assoc_list + (#t : Type0) (ntable : hashMap_t t{length ntable.slots > 0}) (al : assoc_list t) : Type0 = - (forall (k:key). hash_map_t_find_s ntable k == assoc_list_find k al) + (forall (k:key). hashMap_t_find_s ntable k == assoc_list_find k al) -let partial_hash_map_s_find +let partial_hashMap_s_find (#t : Type0) (len : usize{len > 0}) (offset : usize) - (hm : hash_map_s_nes t{offset + length hm = len}) + (hm : hashMap_s_nes t{offset + length hm = len}) (k : key{hash_mod_key k len >= offset}) : option t = let i = hash_mod_key k len in let slot = index hm (i - offset) in @@ -2021,13 +2021,13 @@ val key_in_previous_slot_implies_not_found (#t : Type0) (len : usize{len > 0}) (k : key) (offset : usize) - (slots : hash_map_s t{offset + length slots = len}) : + (slots : hashMap_s t{offset + length slots = len}) : Lemma (requires ( // The binding comes from a slot not in [slots] hash_mod_key k len < offset /\ // The slots are the well-formed suffix of a hash map - partial_hash_map_s_inv len offset slots)) + partial_hashMap_s_inv len offset slots)) (ensures ( assoc_list_find k (flatten slots) == None)) (decreases slots) @@ -2045,19 +2045,19 @@ let rec key_in_previous_slot_implies_not_found #t len k offset slots = key_in_previous_slot_implies_not_found len k (offset+1) slots' #pop-options -val partial_hash_map_s_is_assoc_list_lem +val partial_hashMap_s_is_assoc_list_lem (#t : Type0) (len : usize{len > 0}) (offset : usize) - (hm : hash_map_s_nes t{offset + length hm = len}) + (hm : hashMap_s_nes t{offset + length hm = len}) (k : key{hash_mod_key k len >= offset}) : Lemma (requires ( - partial_hash_map_s_inv len offset hm)) + partial_hashMap_s_inv len offset hm)) (ensures ( - partial_hash_map_s_find len offset hm k == assoc_list_find k (flatten hm))) + partial_hashMap_s_find len offset hm k == assoc_list_find k (flatten hm))) (decreases hm) #push-options "--fuel 1" -let rec partial_hash_map_s_is_assoc_list_lem #t len offset hm k = +let rec partial_hashMap_s_is_assoc_list_lem #t len offset hm k = match hm with | [] -> () | slot :: hm' -> @@ -2066,7 +2066,7 @@ let rec partial_hash_map_s_is_assoc_list_lem #t len offset hm k = if i = 0 then begin // We must look in the current slot - assert(partial_hash_map_s_find len offset hm k == slot_s_find k slot); + assert(partial_hashMap_s_find len offset hm k == slot_s_find k slot); find_append (same_key k) slot (flatten hm'); assert(forall (i:nat{i < length hm'}). index hm' i == index hm (i+1)); // Triggers instantiations key_in_previous_slot_implies_not_found #t len k (offset+1) hm'; @@ -2085,64 +2085,64 @@ let rec partial_hash_map_s_is_assoc_list_lem #t len offset hm k = else begin // We must ignore the current slot - assert(partial_hash_map_s_find len offset hm k == - partial_hash_map_s_find len (offset+1) hm' k); + assert(partial_hashMap_s_find len offset hm k == + partial_hashMap_s_find len (offset+1) hm' k); find_append (same_key k) slot (flatten hm'); assert(index hm 0 == slot); // Triggers instantiations not_same_hash_key_not_found_in_slot #t len k offset slot; assert(forall (i:nat{i < length hm'}). index hm' i == index hm (i+1)); // Triggers instantiations - partial_hash_map_s_is_assoc_list_lem #t len (offset+1) hm' k + partial_hashMap_s_is_assoc_list_lem #t len (offset+1) hm' k end #pop-options -val hash_map_is_assoc_list_lem (#t : Type0) (hm : hash_map_t t) : - Lemma (requires (hash_map_t_base_inv hm)) - (ensures (hash_map_is_assoc_list hm (hash_map_t_al_v hm))) +val hashMap_is_assoc_list_lem (#t : Type0) (hm : hashMap_t t) : + Lemma (requires (hashMap_t_base_inv hm)) + (ensures (hashMap_is_assoc_list hm (hashMap_t_al_v hm))) -let hash_map_is_assoc_list_lem #t hm = +let hashMap_is_assoc_list_lem #t hm = let aux (k:key) : - Lemma (hash_map_t_find_s hm k == assoc_list_find k (hash_map_t_al_v hm)) - [SMTPat (hash_map_t_find_s hm k)] = - let hm_v = hash_map_t_v hm in + Lemma (hashMap_t_find_s hm k == assoc_list_find k (hashMap_t_al_v hm)) + [SMTPat (hashMap_t_find_s hm k)] = + let hm_v = hashMap_t_v hm in let len = length hm_v in - partial_hash_map_s_is_assoc_list_lem #t len 0 hm_v k + partial_hashMap_s_is_assoc_list_lem #t len 0 hm_v k in () /// The final lemma about [move_elements]: calling it on an empty hash table moves /// all the elements to this empty table. -val hash_map_move_elements_fwd_back_lem - (t : Type0) (ntable : hash_map_t t) (slots : vec (list_t t)) : +val hashMap_move_elements_lem + (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) : Lemma (requires ( let al = flatten (slots_t_v slots) in - hash_map_t_base_inv ntable /\ + hashMap_t_base_inv ntable /\ length al <= usize_max /\ assoc_list_inv al /\ // The table is empty - hash_map_t_len_s ntable = 0 /\ - (forall (k:key). hash_map_t_find_s ntable k == None))) + hashMap_t_len_s ntable = 0 /\ + (forall (k:key). hashMap_t_find_s ntable k == None))) (ensures ( let al = flatten (slots_t_v slots) in - match hash_map_move_elements_fwd_back t ntable slots 0, - hash_map_move_elements_s_flat (hash_map_t_v ntable) al + match hashMap_move_elements t ntable slots 0, + hashMap_move_elements_s_flat (hashMap_t_v ntable) al with | Return (ntable', _), Return ntable'_v -> // The invariant is preserved - hash_map_t_base_inv ntable' /\ + hashMap_t_base_inv ntable' /\ // We preserved the parameters - hash_map_t_same_params ntable' ntable /\ + hashMap_t_same_params ntable' ntable /\ // The table has the same number of slots - length ntable'.hash_map_slots = length ntable.hash_map_slots /\ + length ntable'.slots = length ntable.slots /\ // The count is good - hash_map_t_len_s ntable' = length al /\ + hashMap_t_len_s ntable' = length al /\ // The table can be linked to its model (we need this only to reveal // "pretty" functional lemmas to the user in the fsti - so that we // can write lemmas with SMT patterns - this is very F* specific) - hash_map_t_v ntable' == ntable'_v /\ + hashMap_t_v ntable' == ntable'_v /\ // The new table contains exactly all the bindings from the slots - // Rk.: see the comment for [hash_map_is_assoc_list] - hash_map_is_assoc_list ntable' al + // Rk.: see the comment for [hashMap_is_assoc_list] + hashMap_is_assoc_list ntable' al | _ -> False // We can only succeed )) @@ -2154,41 +2154,41 @@ val hash_map_move_elements_fwd_back_lem // lack of ifuel (this kind of proofs is annoying, really). #restart-solver #push-options "--z3rlimit 100" -let hash_map_move_elements_fwd_back_lem t ntable slots = - let ntable_v = hash_map_t_v ntable in +let hashMap_move_elements_lem t ntable slots = + let ntable_v = hashMap_t_v ntable in let slots_v = slots_t_v slots in let al = flatten slots_v in - hash_map_move_elements_fwd_back_lem_refin t ntable slots 0; + hashMap_move_elements_lem_refin t ntable slots 0; begin - match hash_map_move_elements_fwd_back t ntable slots 0, - hash_map_move_elements_s ntable_v slots_v 0 + match hashMap_move_elements t ntable slots 0, + hashMap_move_elements_s ntable_v slots_v 0 with | Fail _, Fail _ -> () | Return (ntable', _), Return ntable'_v -> - assert(hash_map_t_base_inv ntable'); - assert(hash_map_t_v ntable' == ntable'_v) + assert(hashMap_t_base_inv ntable'); + assert(hashMap_t_v ntable' == ntable'_v) | _ -> assert(False) end; - hash_map_move_elements_s_lem_refin_flat ntable_v slots_v 0; + hashMap_move_elements_s_lem_refin_flat ntable_v slots_v 0; begin - match hash_map_move_elements_s ntable_v slots_v 0, - hash_map_move_elements_s_flat ntable_v (flatten_i slots_v 0) + match hashMap_move_elements_s ntable_v slots_v 0, + hashMap_move_elements_s_flat ntable_v (flatten_i slots_v 0) with | Fail _, Fail _ -> () | Return hm, Return hm' -> assert(hm == hm') | _ -> assert(False) end; flatten_0_is_flatten slots_v; // flatten_i slots_v 0 == flatten slots_v - hash_map_move_elements_s_flat_lem ntable_v al; - match hash_map_move_elements_fwd_back t ntable slots 0, - hash_map_move_elements_s_flat ntable_v al + hashMap_move_elements_s_flat_lem ntable_v al; + match hashMap_move_elements t ntable slots 0, + hashMap_move_elements_s_flat ntable_v al with | Return (ntable', _), Return ntable'_v -> - assert(hash_map_t_base_inv ntable'); - assert(length ntable'.hash_map_slots = length ntable.hash_map_slots); - assert(hash_map_t_len_s ntable' = length al); - assert(hash_map_t_v ntable' == ntable'_v); - assert(hash_map_is_assoc_list ntable' al) + assert(hashMap_t_base_inv ntable'); + assert(length ntable'.slots = length ntable.slots); + assert(hashMap_t_len_s ntable' = length al); + assert(hashMap_t_v ntable' == ntable'_v); + assert(hashMap_is_assoc_list ntable' al) | _ -> assert(False) #pop-options @@ -2197,47 +2197,47 @@ let hash_map_move_elements_fwd_back_lem t ntable slots = /// High-level model 1. /// This is one is slightly "crude": we just simplify a bit the function. -let hash_map_try_resize_s_simpl +let hashMap_try_resize_s_simpl (#t : Type0) - (hm : hash_map_t t) : - Pure (result (hash_map_t t)) + (hm : hashMap_t t) : + Pure (result (hashMap_t t)) (requires ( - let (divid, divis) = hm.hash_map_max_load_factor in + let (divid, divis) = hm.max_load_factor in divid > 0 /\ divis > 0)) (ensures (fun _ -> True)) = - let capacity = length hm.hash_map_slots in - let (divid, divis) = hm.hash_map_max_load_factor in + let capacity = length hm.slots in + let (divid, divis) = hm.max_load_factor in if capacity <= (usize_max / 2) / divid then let ncapacity : usize = capacity * 2 in - begin match hash_map_new_with_capacity_fwd t ncapacity divid divis with + begin match hashMap_new_with_capacity t ncapacity divid divis with | Fail e -> Fail e | Return ntable -> - match hash_map_move_elements_fwd_back t ntable hm.hash_map_slots 0 with + match hashMap_move_elements t ntable hm.slots 0 with | Fail e -> Fail e | Return (ntable', _) -> let hm = - { hm with hash_map_slots = ntable'.hash_map_slots; - hash_map_max_load = ntable'.hash_map_max_load } + { hm with slots = ntable'.slots; + max_load = ntable'.max_load } in Return hm end else Return hm -val hash_map_try_resize_fwd_back_lem_refin - (t : Type0) (self : hash_map_t t) : +val hashMap_try_resize_lem_refin + (t : Type0) (self : hashMap_t t) : Lemma (requires ( - let (divid, divis) = self.hash_map_max_load_factor in + let (divid, divis) = self.max_load_factor in divid > 0 /\ divis > 0)) (ensures ( - match hash_map_try_resize_fwd_back t self, - hash_map_try_resize_s_simpl self + match hashMap_try_resize t self, + hashMap_try_resize_s_simpl self with | Fail _, Fail _ -> True | Return hm1, Return hm2 -> hm1 == hm2 | _ -> False)) -let hash_map_try_resize_fwd_back_lem_refin t self = () +let hashMap_try_resize_lem_refin t self = () /// Isolating arithmetic proofs @@ -2342,78 +2342,78 @@ let new_max_load_lem len capacity divid divis = assert(nmax_load >= max_load + 1) #pop-options -val hash_map_try_resize_s_simpl_lem (#t : Type0) (hm : hash_map_t t) : +val hashMap_try_resize_s_simpl_lem (#t : Type0) (hm : hashMap_t t) : Lemma (requires ( // The base invariant is satisfied - hash_map_t_base_inv hm /\ + hashMap_t_base_inv hm /\ // However, the "full" invariant is broken, as we call [try_resize] // only if the current number of entries is > the max load. // // There are two situations: // - either we just reached the max load // - or we were already saturated and can't resize - (let (dividend, divisor) = hm.hash_map_max_load_factor in - hm.hash_map_num_entries == hm.hash_map_max_load + 1 \/ - length hm.hash_map_slots * 2 * dividend > usize_max) + (let (dividend, divisor) = hm.max_load_factor in + hm.num_entries == hm.max_load + 1 \/ + length hm.slots * 2 * dividend > usize_max) )) (ensures ( - match hash_map_try_resize_s_simpl hm with + match hashMap_try_resize_s_simpl hm with | Fail _ -> False | Return hm' -> // The full invariant is now satisfied (the full invariant is "base // invariant" + the map is not overloaded (or can't be resized because // already too big) - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // It contains the same bindings as the initial map - (forall (k:key). hash_map_t_find_s hm' k == hash_map_t_find_s hm k))) + (forall (k:key). hashMap_t_find_s hm' k == hashMap_t_find_s hm k))) #restart-solver #push-options "--z3rlimit 400" -let hash_map_try_resize_s_simpl_lem #t hm = - let capacity = length hm.hash_map_slots in - let (divid, divis) = hm.hash_map_max_load_factor in +let hashMap_try_resize_s_simpl_lem #t hm = + let capacity = length hm.slots in + let (divid, divis) = hm.max_load_factor in if capacity <= (usize_max / 2) / divid then begin let ncapacity : usize = capacity * 2 in assert(ncapacity * divid <= usize_max); - assert(hash_map_t_len_s hm = hm.hash_map_max_load + 1); - new_max_load_lem (hash_map_t_len_s hm) capacity divid divis; - hash_map_new_with_capacity_fwd_lem t ncapacity divid divis; - match hash_map_new_with_capacity_fwd t ncapacity divid divis with + assert(hashMap_t_len_s hm = hm.max_load + 1); + new_max_load_lem (hashMap_t_len_s hm) capacity divid divis; + hashMap_new_with_capacity_lem t ncapacity divid divis; + match hashMap_new_with_capacity t ncapacity divid divis with | Fail _ -> () | Return ntable -> - let slots = hm.hash_map_slots in + let slots = hm.slots in let al = flatten (slots_t_v slots) in - // Proving that: length al = hm.hash_map_num_entries + // Proving that: length al = hm.num_entries assert(al == flatten (map slot_t_v slots)); assert(al == flatten (map list_t_v slots)); - assert(hash_map_t_al_v hm == flatten (hash_map_t_v hm)); - assert(hash_map_t_al_v hm == flatten (map list_t_v hm.hash_map_slots)); - assert(al == hash_map_t_al_v hm); - assert(hash_map_t_base_inv ntable); - assert(length al = hm.hash_map_num_entries); + assert(hashMap_t_al_v hm == flatten (hashMap_t_v hm)); + assert(hashMap_t_al_v hm == flatten (map list_t_v hm.slots)); + assert(al == hashMap_t_al_v hm); + assert(hashMap_t_base_inv ntable); + assert(length al = hm.num_entries); assert(length al <= usize_max); - hash_map_t_base_inv_implies_assoc_list_lem hm; + hashMap_t_base_inv_implies_assoc_list_lem hm; assert(assoc_list_inv al); - assert(hash_map_t_len_s ntable = 0); - assert(forall (k:key). hash_map_t_find_s ntable k == None); - hash_map_move_elements_fwd_back_lem t ntable hm.hash_map_slots; - match hash_map_move_elements_fwd_back t ntable hm.hash_map_slots 0 with + assert(hashMap_t_len_s ntable = 0); + assert(forall (k:key). hashMap_t_find_s ntable k == None); + hashMap_move_elements_lem t ntable hm.slots; + match hashMap_move_elements t ntable hm.slots 0 with | Fail _ -> () | Return (ntable', _) -> - hash_map_is_assoc_list_lem hm; - assert(hash_map_is_assoc_list hm (hash_map_t_al_v hm)); + hashMap_is_assoc_list_lem hm; + assert(hashMap_is_assoc_list hm (hashMap_t_al_v hm)); let hm' = - { hm with hash_map_slots = ntable'.hash_map_slots; - hash_map_max_load = ntable'.hash_map_max_load } + { hm with slots = ntable'.slots; + max_load = ntable'.max_load } in - assert(hash_map_t_base_inv ntable'); - assert(hash_map_t_base_inv hm'); - assert(hash_map_t_len_s hm' = hash_map_t_len_s hm); - new_max_load_lem (hash_map_t_len_s hm') capacity divid divis; - assert(hash_map_t_len_s hm' <= hm'.hash_map_max_load); // Requires a lemma - assert(hash_map_t_inv hm') + assert(hashMap_t_base_inv ntable'); + assert(hashMap_t_base_inv hm'); + assert(hashMap_t_len_s hm' = hashMap_t_len_s hm); + new_max_load_lem (hashMap_t_len_s hm') capacity divid divis; + assert(hashMap_t_len_s hm' <= hm'.max_load); // Requires a lemma + assert(hashMap_t_inv hm') end else begin @@ -2422,203 +2422,203 @@ let hash_map_try_resize_s_simpl_lem #t hm = end #pop-options -let hash_map_t_same_bindings (#t : Type0) (hm hm' : hash_map_t_nes t) : Type0 = - forall (k:key). hash_map_t_find_s hm k == hash_map_t_find_s hm' k +let hashMap_t_same_bindings (#t : Type0) (hm hm' : hashMap_t_nes t) : Type0 = + forall (k:key). hashMap_t_find_s hm k == hashMap_t_find_s hm' k /// The final lemma about [try_resize] -val hash_map_try_resize_fwd_back_lem (#t : Type0) (hm : hash_map_t t) : +val hashMap_try_resize_lem (#t : Type0) (hm : hashMap_t t) : Lemma (requires ( - hash_map_t_base_inv hm /\ + hashMap_t_base_inv hm /\ // However, the "full" invariant is broken, as we call [try_resize] // only if the current number of entries is > the max load. // // There are two situations: // - either we just reached the max load // - or we were already saturated and can't resize - (let (dividend, divisor) = hm.hash_map_max_load_factor in - hm.hash_map_num_entries == hm.hash_map_max_load + 1 \/ - length hm.hash_map_slots * 2 * dividend > usize_max))) + (let (dividend, divisor) = hm.max_load_factor in + hm.num_entries == hm.max_load + 1 \/ + length hm.slots * 2 * dividend > usize_max))) (ensures ( - match hash_map_try_resize_fwd_back t hm with + match hashMap_try_resize t hm with | Fail _ -> False | Return hm' -> // The full invariant is now satisfied (the full invariant is "base // invariant" + the map is not overloaded (or can't be resized because // already too big) - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // The length is the same - hash_map_t_len_s hm' = hash_map_t_len_s hm /\ + hashMap_t_len_s hm' = hashMap_t_len_s hm /\ // It contains the same bindings as the initial map - hash_map_t_same_bindings hm' hm)) + hashMap_t_same_bindings hm' hm)) -let hash_map_try_resize_fwd_back_lem #t hm = - hash_map_try_resize_fwd_back_lem_refin t hm; - hash_map_try_resize_s_simpl_lem hm +let hashMap_try_resize_lem #t hm = + hashMap_try_resize_lem_refin t hm; + hashMap_try_resize_s_simpl_lem hm (*** insert *) /// The high-level model (very close to the original function: we don't need something /// very high level, just to clean it a bit) -let hash_map_insert_s - (#t : Type0) (self : hash_map_t t) (key : usize) (value : t) : - result (hash_map_t t) = - match hash_map_insert_no_resize_fwd_back t self key value with +let hashMap_insert_s + (#t : Type0) (self : hashMap_t t) (key : usize) (value : t) : + result (hashMap_t t) = + match hashMap_insert_no_resize t self key value with | Fail e -> Fail e | Return hm' -> - if hash_map_t_len_s hm' > hm'.hash_map_max_load then - hash_map_try_resize_fwd_back t hm' + if hashMap_t_len_s hm' > hm'.max_load then + hashMap_try_resize t hm' else Return hm' -val hash_map_insert_fwd_back_lem_refin - (t : Type0) (self : hash_map_t t) (key : usize) (value : t) : +val hashMap_insert_lem_refin + (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : Lemma (requires True) (ensures ( - match hash_map_insert_fwd_back t self key value, - hash_map_insert_s self key value + match hashMap_insert t self key value, + hashMap_insert_s self key value with | Fail _, Fail _ -> True | Return hm1, Return hm2 -> hm1 == hm2 | _ -> False)) -let hash_map_insert_fwd_back_lem_refin t self key value = () +let hashMap_insert_lem_refin t self key value = () /// Helper -let hash_map_insert_fwd_back_bindings_lem - (t : Type0) (self : hash_map_t_nes t) (key : usize) (value : t) - (hm' hm'' : hash_map_t_nes t) : +let hashMap_insert_bindings_lem + (t : Type0) (self : hashMap_t_nes t) (key : usize) (value : t) + (hm' hm'' : hashMap_t_nes t) : Lemma (requires ( - hash_map_s_updated_binding (hash_map_t_v self) key - (Some value) (hash_map_t_v hm') /\ - hash_map_t_same_bindings hm' hm'')) + hashMap_s_updated_binding (hashMap_t_v self) key + (Some value) (hashMap_t_v hm') /\ + hashMap_t_same_bindings hm' hm'')) (ensures ( - hash_map_s_updated_binding (hash_map_t_v self) key - (Some value) (hash_map_t_v hm''))) + hashMap_s_updated_binding (hashMap_t_v self) key + (Some value) (hashMap_t_v hm''))) = () -val hash_map_insert_fwd_back_lem_aux - (#t : Type0) (self : hash_map_t t) (key : usize) (value : t) : - Lemma (requires (hash_map_t_inv self)) +val hashMap_insert_lem_aux + (#t : Type0) (self : hashMap_t t) (key : usize) (value : t) : + Lemma (requires (hashMap_t_inv self)) (ensures ( - match hash_map_insert_fwd_back t self key value with + match hashMap_insert t self key value with | Fail _ -> // We can fail only if: // - the key is not in the map and we need to add it // - we are already saturated - hash_map_t_len_s self = usize_max /\ - None? (hash_map_t_find_s self key) + hashMap_t_len_s self = usize_max /\ + None? (hashMap_t_find_s self key) | Return hm' -> // The invariant is preserved - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // [key] maps to [value] and the other bindings are preserved - hash_map_s_updated_binding (hash_map_t_v self) key (Some value) (hash_map_t_v hm') /\ + hashMap_s_updated_binding (hashMap_t_v self) key (Some value) (hashMap_t_v hm') /\ // The length is incremented, iff we inserted a new key - (match hash_map_t_find_s self key with - | None -> hash_map_t_len_s hm' = hash_map_t_len_s self + 1 - | Some _ -> hash_map_t_len_s hm' = hash_map_t_len_s self))) + (match hashMap_t_find_s self key with + | None -> hashMap_t_len_s hm' = hashMap_t_len_s self + 1 + | Some _ -> hashMap_t_len_s hm' = hashMap_t_len_s self))) #restart-solver #push-options "--z3rlimit 200" -let hash_map_insert_fwd_back_lem_aux #t self key value = - hash_map_insert_no_resize_fwd_back_lem_s t self key value; - hash_map_insert_no_resize_s_lem (hash_map_t_v self) key value; - match hash_map_insert_no_resize_fwd_back t self key value with +let hashMap_insert_lem_aux #t self key value = + hashMap_insert_no_resize_lem_s t self key value; + hashMap_insert_no_resize_s_lem (hashMap_t_v self) key value; + match hashMap_insert_no_resize t self key value with | Fail _ -> () | Return hm' -> - // Expanding the post of [hash_map_insert_no_resize_fwd_back_lem_s] - let self_v = hash_map_t_v self in - let hm'_v = Return?.v (hash_map_insert_no_resize_s self_v key value) in - assert(hash_map_t_base_inv hm'); - assert(hash_map_t_same_params hm' self); - assert(hash_map_t_v hm' == hm'_v); - assert(hash_map_s_len hm'_v == hash_map_t_len_s hm'); - // Expanding the post of [hash_map_insert_no_resize_s_lem] + // Expanding the post of [hashMap_insert_no_resize_lem_s] + let self_v = hashMap_t_v self in + let hm'_v = Return?.v (hashMap_insert_no_resize_s self_v key value) in + assert(hashMap_t_base_inv hm'); + assert(hashMap_t_same_params hm' self); + assert(hashMap_t_v hm' == hm'_v); + assert(hashMap_s_len hm'_v == hashMap_t_len_s hm'); + // Expanding the post of [hashMap_insert_no_resize_s_lem] assert(insert_post self_v key value hm'_v); // Expanding [insert_post] - assert(hash_map_s_inv hm'_v); + assert(hashMap_s_inv hm'_v); assert( - match hash_map_s_find self_v key with - | None -> hash_map_s_len hm'_v = hash_map_s_len self_v + 1 - | Some _ -> hash_map_s_len hm'_v = hash_map_s_len self_v); - if hash_map_t_len_s hm' > hm'.hash_map_max_load then + match hashMap_s_find self_v key with + | None -> hashMap_s_len hm'_v = hashMap_s_len self_v + 1 + | Some _ -> hashMap_s_len hm'_v = hashMap_s_len self_v); + if hashMap_t_len_s hm' > hm'.max_load then begin - hash_map_try_resize_fwd_back_lem hm'; - // Expanding the post of [hash_map_try_resize_fwd_back_lem] - let hm'' = Return?.v (hash_map_try_resize_fwd_back t hm') in - assert(hash_map_t_inv hm''); - let hm''_v = hash_map_t_v hm'' in - assert(forall k. hash_map_t_find_s hm'' k == hash_map_t_find_s hm' k); - assert(hash_map_t_len_s hm'' = hash_map_t_len_s hm'); // TODO + hashMap_try_resize_lem hm'; + // Expanding the post of [hashMap_try_resize_lem] + let hm'' = Return?.v (hashMap_try_resize t hm') in + assert(hashMap_t_inv hm''); + let hm''_v = hashMap_t_v hm'' in + assert(forall k. hashMap_t_find_s hm'' k == hashMap_t_find_s hm' k); + assert(hashMap_t_len_s hm'' = hashMap_t_len_s hm'); // TODO // Proving the post - assert(hash_map_t_inv hm''); - hash_map_insert_fwd_back_bindings_lem t self key value hm' hm''; + assert(hashMap_t_inv hm''); + hashMap_insert_bindings_lem t self key value hm' hm''; assert( - match hash_map_t_find_s self key with - | None -> hash_map_t_len_s hm'' = hash_map_t_len_s self + 1 - | Some _ -> hash_map_t_len_s hm'' = hash_map_t_len_s self) + match hashMap_t_find_s self key with + | None -> hashMap_t_len_s hm'' = hashMap_t_len_s self + 1 + | Some _ -> hashMap_t_len_s hm'' = hashMap_t_len_s self) end else () #pop-options -let hash_map_insert_fwd_back_lem #t self key value = - hash_map_insert_fwd_back_lem_aux #t self key value +let hashMap_insert_lem #t self key value = + hashMap_insert_lem_aux #t self key value (*** contains_key *) (**** contains_key_in_list *) -val hash_map_contains_key_in_list_fwd_lem +val hashMap_contains_key_in_list_lem (#t : Type0) (key : usize) (ls : list_t t) : Lemma (ensures ( - match hash_map_contains_key_in_list_fwd t key ls with + match hashMap_contains_key_in_list t key ls with | Fail _ -> False | Return b -> b = Some? (slot_t_find_s key ls))) #push-options "--fuel 1" -let rec hash_map_contains_key_in_list_fwd_lem #t key ls = +let rec hashMap_contains_key_in_list_lem #t key ls = match ls with - | ListCons ckey x ls0 -> + | List_Cons ckey x ls0 -> let b = ckey = key in if b then () else begin - hash_map_contains_key_in_list_fwd_lem key ls0; - match hash_map_contains_key_in_list_fwd t key ls0 with + hashMap_contains_key_in_list_lem key ls0; + match hashMap_contains_key_in_list t key ls0 with | Fail _ -> () | Return b0 -> () end - | ListNil -> () + | List_Nil -> () #pop-options (**** contains_key *) -val hash_map_contains_key_fwd_lem_aux - (#t : Type0) (self : hash_map_t_nes t) (key : usize) : +val hashMap_contains_key_lem_aux + (#t : Type0) (self : hashMap_t_nes t) (key : usize) : Lemma (ensures ( - match hash_map_contains_key_fwd t self key with + match hashMap_contains_key t self key with | Fail _ -> False - | Return b -> b = Some? (hash_map_t_find_s self key))) + | Return b -> b = Some? (hashMap_t_find_s self key))) -let hash_map_contains_key_fwd_lem_aux #t self key = - begin match hash_key_fwd key with +let hashMap_contains_key_lem_aux #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let v = self.hash_map_slots in - let i0 = vec_len (list_t t) v in + let v = self.slots in + let i0 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i0 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> - hash_map_contains_key_in_list_fwd_lem key l; - begin match hash_map_contains_key_in_list_fwd t key l with + hashMap_contains_key_in_list_lem key l; + begin match hashMap_contains_key_in_list t key l with | Fail _ -> () | Return b -> () end @@ -2627,66 +2627,66 @@ let hash_map_contains_key_fwd_lem_aux #t self key = end /// The lemma in the .fsti -let hash_map_contains_key_fwd_lem #t self key = - hash_map_contains_key_fwd_lem_aux #t self key +let hashMap_contains_key_lem #t self key = + hashMap_contains_key_lem_aux #t self key (*** get *) (**** get_in_list *) -val hash_map_get_in_list_fwd_lem +val hashMap_get_in_list_lem (#t : Type0) (key : usize) (ls : list_t t) : Lemma (ensures ( - match hash_map_get_in_list_fwd t key ls, slot_t_find_s key ls with + match hashMap_get_in_list t key ls, slot_t_find_s key ls with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) #push-options "--fuel 1" -let rec hash_map_get_in_list_fwd_lem #t key ls = +let rec hashMap_get_in_list_lem #t key ls = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_get_in_list_fwd_lem key ls0; - match hash_map_get_in_list_fwd t key ls0 with + hashMap_get_in_list_lem key ls0; + match hashMap_get_in_list t key ls0 with | Fail _ -> () | Return x -> () end - | ListNil -> () + | List_Nil -> () end #pop-options (**** get *) -val hash_map_get_fwd_lem_aux - (#t : Type0) (self : hash_map_t_nes t) (key : usize) : +val hashMap_get_lem_aux + (#t : Type0) (self : hashMap_t_nes t) (key : usize) : Lemma (ensures ( - match hash_map_get_fwd t self key, hash_map_t_find_s self key with + match hashMap_get t self key, hashMap_t_find_s self key with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) -let hash_map_get_fwd_lem_aux #t self key = - begin match hash_key_fwd key with +let hashMap_get_lem_aux #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let v = self.hash_map_slots in - let i0 = vec_len (list_t t) v in + let v = self.slots in + let i0 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i0 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_get_in_list_fwd_lem key l; - match hash_map_get_in_list_fwd t key l with + hashMap_get_in_list_lem key l; + match hashMap_get_in_list t key l with | Fail _ -> () | Return x -> () end @@ -2695,66 +2695,66 @@ let hash_map_get_fwd_lem_aux #t self key = end /// .fsti -let hash_map_get_fwd_lem #t self key = hash_map_get_fwd_lem_aux #t self key +let hashMap_get_lem #t self key = hashMap_get_lem_aux #t self key (*** get_mut'fwd *) (**** get_mut_in_list'fwd *) -val hash_map_get_mut_in_list_loop_fwd_lem +val hashMap_get_mut_in_list_loop_lem (#t : Type0) (ls : list_t t) (key : usize) : Lemma (ensures ( - match hash_map_get_mut_in_list_loop_fwd t ls key, slot_t_find_s key ls with + match hashMap_get_mut_in_list_loop t ls key, slot_t_find_s key ls with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) #push-options "--fuel 1" -let rec hash_map_get_mut_in_list_loop_fwd_lem #t ls key = +let rec hashMap_get_mut_in_list_loop_lem #t ls key = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_get_mut_in_list_loop_fwd_lem ls0 key; - match hash_map_get_mut_in_list_loop_fwd t ls0 key with + hashMap_get_mut_in_list_loop_lem ls0 key; + match hashMap_get_mut_in_list_loop t ls0 key with | Fail _ -> () | Return x -> () end - | ListNil -> () + | List_Nil -> () end #pop-options (**** get_mut'fwd *) -val hash_map_get_mut_fwd_lem_aux - (#t : Type0) (self : hash_map_t_nes t) (key : usize) : +val hashMap_get_mut_lem_aux + (#t : Type0) (self : hashMap_t_nes t) (key : usize) : Lemma (ensures ( - match hash_map_get_mut_fwd t self key, hash_map_t_find_s self key with + match hashMap_get_mut t self key, hashMap_t_find_s self key with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) -let hash_map_get_mut_fwd_lem_aux #t self key = - begin match hash_key_fwd key with +let hashMap_get_mut_lem_aux #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let v = self.hash_map_slots in - let i0 = vec_len (list_t t) v in + let v = self.slots in + let i0 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i0 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_get_mut_in_list_loop_fwd_lem l key; - match hash_map_get_mut_in_list_loop_fwd t l key with + hashMap_get_mut_in_list_loop_lem l key; + match hashMap_get_mut_in_list_loop t l key with | Fail _ -> () | Return x -> () end @@ -2762,78 +2762,78 @@ let hash_map_get_mut_fwd_lem_aux #t self key = end end -let hash_map_get_mut_fwd_lem #t self key = - hash_map_get_mut_fwd_lem_aux #t self key +let hashMap_get_mut_lem #t self key = + hashMap_get_mut_lem_aux #t self key (*** get_mut'back *) (**** get_mut_in_list'back *) -val hash_map_get_mut_in_list_loop_back_lem +val hashMap_get_mut_in_list_loop_back_lem (#t : Type0) (ls : list_t t) (key : usize) (ret : t) : Lemma (requires (Some? (slot_t_find_s key ls))) (ensures ( - match hash_map_get_mut_in_list_loop_back t ls key ret with + match hashMap_get_mut_in_list_loop_back t ls key ret with | Fail _ -> False | Return ls' -> list_t_v ls' == find_update (same_key key) (list_t_v ls) (key,ret) | _ -> False)) #push-options "--fuel 1" -let rec hash_map_get_mut_in_list_loop_back_lem #t ls key ret = +let rec hashMap_get_mut_in_list_loop_back_lem #t ls key ret = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b - then let ls1 = ListCons ckey ret ls0 in () + then let ls1 = List_Cons ckey ret ls0 in () else begin - hash_map_get_mut_in_list_loop_back_lem ls0 key ret; - match hash_map_get_mut_in_list_loop_back t ls0 key ret with + hashMap_get_mut_in_list_loop_back_lem ls0 key ret; + match hashMap_get_mut_in_list_loop_back t ls0 key ret with | Fail _ -> () - | Return l -> let ls1 = ListCons ckey cvalue l in () + | Return l -> let ls1 = List_Cons ckey cvalue l in () end - | ListNil -> () + | List_Nil -> () end #pop-options (**** get_mut'back *) /// Refinement lemma -val hash_map_get_mut_back_lem_refin - (#t : Type0) (self : hash_map_t t{length self.hash_map_slots > 0}) +val hashMap_get_mut_back_lem_refin + (#t : Type0) (self : hashMap_t t{length self.slots > 0}) (key : usize) (ret : t) : Lemma - (requires (Some? (hash_map_t_find_s self key))) + (requires (Some? (hashMap_t_find_s self key))) (ensures ( - match hash_map_get_mut_back t self key ret with + match hashMap_get_mut_back t self key ret with | Fail _ -> False | Return hm' -> - hash_map_t_v hm' == hash_map_insert_no_fail_s (hash_map_t_v self) key ret)) + hashMap_t_v hm' == hashMap_insert_no_fail_s (hashMap_t_v self) key ret)) -let hash_map_get_mut_back_lem_refin #t self key ret = - begin match hash_key_fwd key with +let hashMap_get_mut_back_lem_refin #t self key ret = + begin match hash_key key with | Fail _ -> () | Return i -> - let i0 = self.hash_map_num_entries in - let p = self.hash_map_max_load_factor in - let i1 = self.hash_map_max_load in - let v = self.hash_map_slots in - let i2 = vec_len (list_t t) v in + let i0 = self.num_entries in + let p = self.max_load_factor in + let i1 = self.max_load in + let v = self.slots in + let i2 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i2 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_mut_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_get_mut_in_list_loop_back_lem l key ret; - match hash_map_get_mut_in_list_loop_back t l key ret with + hashMap_get_mut_in_list_loop_back_lem l key ret; + match hashMap_get_mut_in_list_loop_back t l key ret with | Fail _ -> () | Return l0 -> - begin match vec_index_mut_back (list_t t) v hash_mod l0 with + begin match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () - | Return v0 -> let self0 = Mkhash_map_t i0 p i1 v0 in () + | Return v0 -> let self0 = MkhashMap_t i0 p i1 v0 in () end end end @@ -2841,102 +2841,102 @@ let hash_map_get_mut_back_lem_refin #t self key ret = end /// Final lemma -val hash_map_get_mut_back_lem_aux - (#t : Type0) (hm : hash_map_t t) +val hashMap_get_mut_back_lem_aux + (#t : Type0) (hm : hashMap_t t) (key : usize) (ret : t) : Lemma (requires ( - hash_map_t_inv hm /\ - Some? (hash_map_t_find_s hm key))) + hashMap_t_inv hm /\ + Some? (hashMap_t_find_s hm key))) (ensures ( - match hash_map_get_mut_back t hm key ret with + match hashMap_get_mut_back t hm key ret with | Fail _ -> False | Return hm' -> // Functional spec - hash_map_t_v hm' == hash_map_insert_no_fail_s (hash_map_t_v hm) key ret /\ + hashMap_t_v hm' == hashMap_insert_no_fail_s (hashMap_t_v hm) key ret /\ // The invariant is preserved - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // The length is preserved - hash_map_t_len_s hm' = hash_map_t_len_s hm /\ + hashMap_t_len_s hm' = hashMap_t_len_s hm /\ // [key] maps to [value] - hash_map_t_find_s hm' key == Some ret /\ + hashMap_t_find_s hm' key == Some ret /\ // The other bindings are preserved - (forall k'. k' <> key ==> hash_map_t_find_s hm' k' == hash_map_t_find_s hm k'))) + (forall k'. k' <> key ==> hashMap_t_find_s hm' k' == hashMap_t_find_s hm k'))) -let hash_map_get_mut_back_lem_aux #t hm key ret = - let hm_v = hash_map_t_v hm in - hash_map_get_mut_back_lem_refin hm key ret; - match hash_map_get_mut_back t hm key ret with +let hashMap_get_mut_back_lem_aux #t hm key ret = + let hm_v = hashMap_t_v hm in + hashMap_get_mut_back_lem_refin hm key ret; + match hashMap_get_mut_back t hm key ret with | Fail _ -> assert(False) | Return hm' -> - hash_map_insert_no_fail_s_lem hm_v key ret + hashMap_insert_no_fail_s_lem hm_v key ret /// .fsti -let hash_map_get_mut_back_lem #t hm key ret = hash_map_get_mut_back_lem_aux hm key ret +let hashMap_get_mut_back_lem #t hm key ret = hashMap_get_mut_back_lem_aux hm key ret (*** remove'fwd *) -val hash_map_remove_from_list_fwd_lem +val hashMap_remove_from_list_lem (#t : Type0) (key : usize) (ls : list_t t) : Lemma (ensures ( - match hash_map_remove_from_list_fwd t key ls with + match hashMap_remove_from_list t key ls with | Fail _ -> False | Return opt_x -> opt_x == slot_t_find_s key ls /\ (Some? opt_x ==> length (slot_t_v ls) > 0))) #push-options "--fuel 1" -let rec hash_map_remove_from_list_fwd_lem #t key ls = +let rec hashMap_remove_from_list_lem #t key ls = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> let b = ckey = key in if b then - let mv_ls = mem_replace_fwd (list_t t) (ListCons ckey x tl) ListNil in + let mv_ls = core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in begin match mv_ls with - | ListCons i cvalue tl0 -> () - | ListNil -> () + | List_Cons i cvalue tl0 -> () + | List_Nil -> () end else begin - hash_map_remove_from_list_fwd_lem key tl; - match hash_map_remove_from_list_fwd t key tl with + hashMap_remove_from_list_lem key tl; + match hashMap_remove_from_list t key tl with | Fail _ -> () | Return opt -> () end - | ListNil -> () + | List_Nil -> () end #pop-options -val hash_map_remove_fwd_lem_aux - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_remove_lem_aux + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma (requires ( // We need the invariant to prove that upon decrementing the entries counter, // the counter doesn't become negative - hash_map_t_inv self)) + hashMap_t_inv self)) (ensures ( - match hash_map_remove_fwd t self key with + match hashMap_remove t self key with | Fail _ -> False - | Return opt_x -> opt_x == hash_map_t_find_s self key)) + | Return opt_x -> opt_x == hashMap_t_find_s self key)) -let hash_map_remove_fwd_lem_aux #t self key = - begin match hash_key_fwd key with +let hashMap_remove_lem_aux #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let i0 = self.hash_map_num_entries in - let v = self.hash_map_slots in - let i1 = vec_len (list_t t) v in + let i0 = self.num_entries in + let v = self.slots in + let i1 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i1 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_mut_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_remove_from_list_fwd_lem key l; - match hash_map_remove_from_list_fwd t key l with + hashMap_remove_from_list_lem key l; + match hashMap_remove_from_list t key l with | Fail _ -> () | Return x -> begin match x with @@ -2945,7 +2945,7 @@ let hash_map_remove_fwd_lem_aux #t self key = begin assert(l == index v hash_mod); assert(length (list_t_v #t l) > 0); - length_flatten_index (hash_map_t_v self) hash_mod; + length_flatten_index (hashMap_t_v self) hash_mod; match usize_sub i0 1 with | Fail _ -> () | Return _ -> () @@ -2957,27 +2957,27 @@ let hash_map_remove_fwd_lem_aux #t self key = end /// .fsti -let hash_map_remove_fwd_lem #t self key = hash_map_remove_fwd_lem_aux #t self key +let hashMap_remove_lem #t self key = hashMap_remove_lem_aux #t self key (*** remove'back *) (**** Refinement proofs *) /// High-level model for [remove_from_list'back] -let hash_map_remove_from_list_s +let hashMap_remove_from_list_s (#t : Type0) (key : usize) (ls : slot_s t) : slot_s t = filter_one (not_same_key key) ls /// Refinement lemma -val hash_map_remove_from_list_back_lem_refin +val hashMap_remove_from_list_back_lem_refin (#t : Type0) (key : usize) (ls : list_t t) : Lemma (ensures ( - match hash_map_remove_from_list_back t key ls with + match hashMap_remove_from_list_back t key ls with | Fail _ -> False | Return ls' -> - list_t_v ls' == hash_map_remove_from_list_s key (list_t_v ls) /\ + list_t_v ls' == hashMap_remove_from_list_s key (list_t_v ls) /\ // The length is decremented, iff the key was in the slot (let len = length (list_t_v ls) in let len' = length (list_t_v ls') in @@ -2986,89 +2986,89 @@ val hash_map_remove_from_list_back_lem_refin | Some _ -> len = len' + 1))) #push-options "--fuel 1" -let rec hash_map_remove_from_list_back_lem_refin #t key ls = +let rec hashMap_remove_from_list_back_lem_refin #t key ls = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> let b = ckey = key in if b then - let mv_ls = mem_replace_fwd (list_t t) (ListCons ckey x tl) ListNil in + let mv_ls = core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in begin match mv_ls with - | ListCons i cvalue tl0 -> () - | ListNil -> () + | List_Cons i cvalue tl0 -> () + | List_Nil -> () end else begin - hash_map_remove_from_list_back_lem_refin key tl; - match hash_map_remove_from_list_back t key tl with + hashMap_remove_from_list_back_lem_refin key tl; + match hashMap_remove_from_list_back t key tl with | Fail _ -> () - | Return l -> let ls0 = ListCons ckey x l in () + | Return l -> let ls0 = List_Cons ckey x l in () end - | ListNil -> () + | List_Nil -> () end #pop-options /// High-level model for [remove_from_list'back] -let hash_map_remove_s - (#t : Type0) (self : hash_map_s_nes t) (key : usize) : - hash_map_s t = +let hashMap_remove_s + (#t : Type0) (self : hashMap_s_nes t) (key : usize) : + hashMap_s t = let len = length self in let hash = hash_mod_key key len in let slot = index self hash in - let slot' = hash_map_remove_from_list_s key slot in + let slot' = hashMap_remove_from_list_s key slot in list_update self hash slot' /// Refinement lemma -val hash_map_remove_back_lem_refin - (#t : Type0) (self : hash_map_t_nes t) (key : usize) : +val hashMap_remove_back_lem_refin + (#t : Type0) (self : hashMap_t_nes t) (key : usize) : Lemma (requires ( // We need the invariant to prove that upon decrementing the entries counter, // the counter doesn't become negative - hash_map_t_inv self)) + hashMap_t_inv self)) (ensures ( - match hash_map_remove_back t self key with + match hashMap_remove_back t self key with | Fail _ -> False | Return hm' -> - hash_map_t_same_params hm' self /\ - hash_map_t_v hm' == hash_map_remove_s (hash_map_t_v self) key /\ + hashMap_t_same_params hm' self /\ + hashMap_t_v hm' == hashMap_remove_s (hashMap_t_v self) key /\ // The length is decremented iff the key was in the map - (let len = hash_map_t_len_s self in - let len' = hash_map_t_len_s hm' in - match hash_map_t_find_s self key with + (let len = hashMap_t_len_s self in + let len' = hashMap_t_len_s hm' in + match hashMap_t_find_s self key with | None -> len = len' | Some _ -> len = len' + 1))) -let hash_map_remove_back_lem_refin #t self key = - begin match hash_key_fwd key with +let hashMap_remove_back_lem_refin #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let i0 = self.hash_map_num_entries in - let p = self.hash_map_max_load_factor in - let i1 = self.hash_map_max_load in - let v = self.hash_map_slots in - let i2 = vec_len (list_t t) v in + let i0 = self.num_entries in + let p = self.max_load_factor in + let i1 = self.max_load in + let v = self.slots in + let i2 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i2 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_mut_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_remove_from_list_fwd_lem key l; - match hash_map_remove_from_list_fwd t key l with + hashMap_remove_from_list_lem key l; + match hashMap_remove_from_list t key l with | Fail _ -> () | Return x -> begin match x with | None -> begin - hash_map_remove_from_list_back_lem_refin key l; - match hash_map_remove_from_list_back t key l with + hashMap_remove_from_list_back_lem_refin key l; + match hashMap_remove_from_list_back t key l with | Fail _ -> () | Return l0 -> begin length_flatten_update (slots_t_v v) hash_mod (list_t_v l0); - match vec_index_mut_back (list_t t) v hash_mod l0 with + match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () | Return v0 -> () end @@ -3077,18 +3077,18 @@ let hash_map_remove_back_lem_refin #t self key = begin assert(l == index v hash_mod); assert(length (list_t_v #t l) > 0); - length_flatten_index (hash_map_t_v self) hash_mod; + length_flatten_index (hashMap_t_v self) hash_mod; match usize_sub i0 1 with | Fail _ -> () | Return i3 -> begin - hash_map_remove_from_list_back_lem_refin key l; - match hash_map_remove_from_list_back t key l with + hashMap_remove_from_list_back_lem_refin key l; + match hashMap_remove_from_list_back t key l with | Fail _ -> () | Return l0 -> begin length_flatten_update (slots_t_v v) hash_mod (list_t_v l0); - match vec_index_mut_back (list_t t) v hash_mod l0 with + match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () | Return v0 -> () end @@ -3102,12 +3102,12 @@ let hash_map_remove_back_lem_refin #t self key = (**** Invariants, high-level properties *) -val hash_map_remove_from_list_s_lem +val hashMap_remove_from_list_s_lem (#t : Type0) (k : usize) (slot : slot_s t) (len : usize{len > 0}) (i : usize) : Lemma (requires (slot_s_inv len i slot)) (ensures ( - let slot' = hash_map_remove_from_list_s k slot in + let slot' = hashMap_remove_from_list_s k slot in slot_s_inv len i slot' /\ slot_s_find k slot' == None /\ (forall (k':key{k' <> k}). slot_s_find k' slot' == slot_s_find k' slot) /\ @@ -3117,14 +3117,14 @@ val hash_map_remove_from_list_s_lem )) #push-options "--fuel 1" -let rec hash_map_remove_from_list_s_lem #t key slot len i = +let rec hashMap_remove_from_list_s_lem #t key slot len i = match slot with | [] -> () | (k',v) :: slot' -> if k' <> key then begin - hash_map_remove_from_list_s_lem key slot' len i; - let slot'' = hash_map_remove_from_list_s key slot' in + hashMap_remove_from_list_s_lem key slot' len i; + let slot'' = hashMap_remove_from_list_s key slot' in assert(for_all (same_hash_mod_key len i) ((k',v)::slot'')); assert(for_all (binding_neq (k',v)) slot'); // Triggers instanciation assert(for_all (binding_neq (k',v)) slot'') @@ -3136,51 +3136,51 @@ let rec hash_map_remove_from_list_s_lem #t key slot len i = end #pop-options -val hash_map_remove_s_lem - (#t : Type0) (self : hash_map_s_nes t) (key : usize) : +val hashMap_remove_s_lem + (#t : Type0) (self : hashMap_s_nes t) (key : usize) : Lemma - (requires (hash_map_s_inv self)) + (requires (hashMap_s_inv self)) (ensures ( - let hm' = hash_map_remove_s self key in + let hm' = hashMap_remove_s self key in // The invariant is preserved - hash_map_s_inv hm' /\ + hashMap_s_inv hm' /\ // We updated the binding - hash_map_s_updated_binding self key None hm')) + hashMap_s_updated_binding self key None hm')) -let hash_map_remove_s_lem #t self key = +let hashMap_remove_s_lem #t self key = let len = length self in let hash = hash_mod_key key len in let slot = index self hash in - hash_map_remove_from_list_s_lem key slot len hash; - let slot' = hash_map_remove_from_list_s key slot in + hashMap_remove_from_list_s_lem key slot len hash; + let slot' = hashMap_remove_from_list_s key slot in let hm' = list_update self hash slot' in - assert(hash_map_s_inv self) + assert(hashMap_s_inv self) /// Final lemma about [remove'back] -val hash_map_remove_back_lem_aux - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_remove_back_lem_aux + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_remove_back t self key with + match hashMap_remove_back t self key with | Fail _ -> False | Return hm' -> - hash_map_t_inv self /\ - hash_map_t_same_params hm' self /\ + hashMap_t_inv self /\ + hashMap_t_same_params hm' self /\ // We updated the binding - hash_map_s_updated_binding (hash_map_t_v self) key None (hash_map_t_v hm') /\ - hash_map_t_v hm' == hash_map_remove_s (hash_map_t_v self) key /\ + hashMap_s_updated_binding (hashMap_t_v self) key None (hashMap_t_v hm') /\ + hashMap_t_v hm' == hashMap_remove_s (hashMap_t_v self) key /\ // The length is decremented iff the key was in the map - (let len = hash_map_t_len_s self in - let len' = hash_map_t_len_s hm' in - match hash_map_t_find_s self key with + (let len = hashMap_t_len_s self in + let len' = hashMap_t_len_s hm' in + match hashMap_t_find_s self key with | None -> len = len' | Some _ -> len = len' + 1))) -let hash_map_remove_back_lem_aux #t self key = - hash_map_remove_back_lem_refin self key; - hash_map_remove_s_lem (hash_map_t_v self) key +let hashMap_remove_back_lem_aux #t self key = + hashMap_remove_back_lem_refin self key; + hashMap_remove_s_lem (hashMap_t_v self) key /// .fsti -let hash_map_remove_back_lem #t self key = - hash_map_remove_back_lem_aux #t self key +let hashMap_remove_back_lem #t self key = + hashMap_remove_back_lem_aux #t self key diff --git a/tests/fstar/hashmap/Hashmap.Properties.fsti b/tests/fstar/hashmap/Hashmap.Properties.fsti index 0a4f0134..26c0ec06 100644 --- a/tests/fstar/hashmap/Hashmap.Properties.fsti +++ b/tests/fstar/hashmap/Hashmap.Properties.fsti @@ -18,11 +18,11 @@ type key : eqtype = usize type hash : eqtype = usize -val hash_map_t_inv (#t : Type0) (hm : hash_map_t t) : Type0 +val hashMap_t_inv (#t : Type0) (hm : hashMap_t t) : Type0 -val len_s (#t : Type0) (hm : hash_map_t t) : nat +val len_s (#t : Type0) (hm : hashMap_t t) : nat -val find_s (#t : Type0) (hm : hash_map_t t) (k : key) : option t +val find_s (#t : Type0) (hm : hashMap_t t) (k : key) : option t (*** Overloading *) @@ -32,16 +32,16 @@ val find_s (#t : Type0) (hm : hash_map_t t) (k : key) : option t /// limiting the hash collisions. /// This is expressed by the following property, which is maintained in the hash /// map invariant. -val hash_map_not_overloaded_lem (#t : Type0) (hm : hash_map_t t) : +val hashMap_not_overloaded_lem (#t : Type0) (hm : hashMap_t t) : Lemma - (requires (hash_map_t_inv hm)) + (requires (hashMap_t_inv hm)) (ensures ( // The capacity is the number of slots - let capacity = length hm.hash_map_slots in + let capacity = length hm.slots in // The max load factor defines a threshold on the number of entries: // if there are more entries than a given fraction of the number of slots, // we resize the slots vector to limit the hash collisions - let (dividend, divisor) = hm.hash_map_max_load_factor in + let (dividend, divisor) = hm.max_load_factor in // technicality: this postcondition won't typecheck if we don't reveal // that divisor > 0 (because of the division) divisor > 0 /\ @@ -63,14 +63,14 @@ val hash_map_not_overloaded_lem (#t : Type0) (hm : hash_map_t t) : (**** [new'fwd] *) /// [new] doesn't fail and returns an empty hash map -val hash_map_new_fwd_lem (t : Type0) : +val hashMap_new_lem (t : Type0) : Lemma (ensures ( - match hash_map_new_fwd t with + match hashMap_new t with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // The hash map has a length of 0 len_s hm = 0 /\ // It contains no bindings @@ -79,16 +79,16 @@ val hash_map_new_fwd_lem (t : Type0) : (**** [clear] *) /// [clear] doesn't fail and turns the hash map into an empty map -val hash_map_clear_fwd_back_lem - (#t : Type0) (self : hash_map_t t) : +val hashMap_clear_lem + (#t : Type0) (self : hashMap_t t) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_clear_fwd_back t self with + match hashMap_clear t self with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // The hash map has a length of 0 len_s hm = 0 /\ // It contains no bindings @@ -97,11 +97,11 @@ val hash_map_clear_fwd_back_lem (**** [len] *) /// [len] can't fail and returns the length (the number of elements) of the hash map -val hash_map_len_fwd_lem (#t : Type0) (self : hash_map_t t) : +val hashMap_len_lem (#t : Type0) (self : hashMap_t t) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_len_fwd t self with + match hashMap_len t self with | Fail _ -> False | Return l -> l = len_s self)) @@ -114,12 +114,12 @@ val hash_map_len_fwd_lem (#t : Type0) (self : hash_map_t t) : /// entirely encompassed by the effect of the backward function alone). /// /// [insert'fwd_back] simply inserts a binding. -val hash_map_insert_fwd_back_lem - (#t : Type0) (self : hash_map_t t) (key : usize) (value : t) : +val hashMap_insert_lem + (#t : Type0) (self : hashMap_t t) (key : usize) (value : t) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_insert_fwd_back t self key value with + match hashMap_insert t self key value with | Fail _ -> // We can fail only if: // - the key is not in the map and we thus need to add it @@ -128,7 +128,7 @@ val hash_map_insert_fwd_back_lem len_s self = usize_max | Return hm' -> // The invariant is preserved - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // [key] maps to [value] find_s hm' key == Some value /\ // The other bindings are preserved @@ -145,24 +145,24 @@ val hash_map_insert_fwd_back_lem /// [contains_key'fwd] can't fail and returns `true` if and only if there is /// a binding for key [key] -val hash_map_contains_key_fwd_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_contains_key_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_contains_key_fwd t self key with + match hashMap_contains_key t self key with | Fail _ -> False | Return b -> b = Some? (find_s self key))) (**** [get'fwd] *) /// [get] returns (a shared borrow to) the binding for key [key] -val hash_map_get_fwd_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_get_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_get_fwd t self key, find_s self key with + match hashMap_get t self key, find_s self key with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) @@ -175,12 +175,12 @@ val hash_map_get_fwd_lem /// in Rust, which gives the possibility of modifying this element in place. Then, /// upon ending the borrow, the effect of the modification is modelled in the /// translation through a call to the backward function. -val hash_map_get_mut_fwd_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_get_mut_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_get_mut_fwd t self key, find_s self key with + match hashMap_get_mut t self key, find_s self key with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) @@ -192,11 +192,11 @@ val hash_map_get_mut_fwd_lem /// A call to [get_mut'back] must follow a call to [get_mut'fwd], which gives /// us that there must be a binding for key [key] in the map (otherwise we /// can't prove the absence of failure). -val hash_map_get_mut_back_lem - (#t : Type0) (hm : hash_map_t t) (key : usize) (ret : t) : +val hashMap_get_mut_back_lem + (#t : Type0) (hm : hashMap_t t) (key : usize) (ret : t) : Lemma (requires ( - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // A call to the backward function must follow a call to the forward // function, whose success gives us that there is a binding for the key. // In the case of *forward* functions, "success" has to be understood as @@ -207,14 +207,14 @@ val hash_map_get_mut_back_lem // "failure" is to be understood as the semantics getting stuck. // This is of course true unless we filtered the call to the forward function // because its effect is encompassed by the backward function, as with - // [hash_map_clear_fwd_back]). + // [hashMap_clear]). Some? (find_s hm key))) (ensures ( - match hash_map_get_mut_back t hm key ret with + match hashMap_get_mut_back t hm key ret with | Fail _ -> False // Can't fail | Return hm' -> // The invariant is preserved - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // The length is preserved len_s hm' = len_s hm /\ // [key] maps to the update value, [ret] @@ -228,12 +228,12 @@ val hash_map_get_mut_back_lem /// (the rust function *moves* it out of the map). Note that the effect of the update /// on the map is modelles through the call to [remove'back] ([remove] takes a /// mutable borrow to the hash map as parameter). -val hash_map_remove_fwd_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_remove_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_remove_fwd t self key with + match hashMap_remove t self key with | Fail _ -> False | Return opt_x -> opt_x == find_s self key)) @@ -243,16 +243,16 @@ val hash_map_remove_fwd_lem /// The hash map given as parameter to [remove] is given through a mutable borrow: /// hence the backward function which gives back the updated map, without the /// binding. -val hash_map_remove_back_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_remove_back_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_remove_back t self key with + match hashMap_remove_back t self key with | Fail _ -> False | Return hm' -> // The invariant is preserved - hash_map_t_inv self /\ + hashMap_t_inv self /\ // The binding for [key] is not there anymore find_s hm' key == None /\ // The other bindings are preserved diff --git a/tests/fstar/hashmap/Hashmap.Types.fst b/tests/fstar/hashmap/Hashmap.Types.fst index 91ee26c6..753730fe 100644 --- a/tests/fstar/hashmap/Hashmap.Types.fst +++ b/tests/fstar/hashmap/Hashmap.Types.fst @@ -7,15 +7,15 @@ open Primitives (** [hashmap::List] *) type list_t (t : Type0) = -| ListCons : usize -> t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : usize -> t -> list_t t -> list_t t +| List_Nil : list_t t (** [hashmap::HashMap] *) -type hash_map_t (t : Type0) = +type hashMap_t (t : Type0) = { - hash_map_num_entries : usize; - hash_map_max_load_factor : (usize & usize); - hash_map_max_load : usize; - hash_map_slots : vec (list_t t); + num_entries : usize; + max_load_factor : (usize & usize); + max_load : usize; + slots : alloc_vec_Vec (list_t t); } diff --git a/tests/fstar/hashmap/Primitives.fst b/tests/fstar/hashmap/Primitives.fst index 9db82069..3297803c 100644 --- a/tests/fstar/hashmap/Primitives.fst +++ b/tests/fstar/hashmap/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -169,17 +187,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize @@ -231,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -259,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -278,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -295,55 +389,54 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -358,18 +451,279 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst index 615c670d..61885ac7 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst @@ -8,56 +8,56 @@ open HashmapMain.Types (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: decreases clause *) unfold -let hashmap_hash_map_allocate_slots_loop_decreases (t : Type0) - (slots : vec (hashmap_list_t t)) (n : usize) : nat = +let hashmap_HashMap_allocate_slots_loop_decreases (t : Type0) + (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::clear]: decreases clause *) unfold -let hashmap_hash_map_clear_loop_decreases (t : Type0) - (slots : vec (hashmap_list_t t)) (i : usize) : nat = +let hashmap_HashMap_clear_loop_decreases (t : Type0) + (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: decreases clause *) unfold -let hashmap_hash_map_insert_in_list_loop_decreases (t : Type0) (key : usize) - (value : t) (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) + (value : t) (ls : hashmap_List_t t) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: decreases clause *) unfold -let hashmap_hash_map_move_elements_from_list_loop_decreases (t : Type0) - (ntable : hashmap_hash_map_t t) (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_move_elements_from_list_loop_decreases (t : Type0) + (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: decreases clause *) unfold -let hashmap_hash_map_move_elements_loop_decreases (t : Type0) - (ntable : hashmap_hash_map_t t) (slots : vec (hashmap_list_t t)) (i : usize) - : nat = +let hashmap_HashMap_move_elements_loop_decreases (t : Type0) + (ntable : hashmap_HashMap_t t) (slots : alloc_vec_Vec (hashmap_List_t t)) + (i : usize) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: decreases clause *) unfold -let hashmap_hash_map_contains_key_in_list_loop_decreases (t : Type0) - (key : usize) (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_contains_key_in_list_loop_decreases (t : Type0) + (key : usize) (ls : hashmap_List_t t) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: decreases clause *) unfold -let hashmap_hash_map_get_in_list_loop_decreases (t : Type0) (key : usize) - (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_get_in_list_loop_decreases (t : Type0) (key : usize) + (ls : hashmap_List_t t) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: decreases clause *) unfold -let hashmap_hash_map_get_mut_in_list_loop_decreases (t : Type0) - (ls : hashmap_list_t t) (key : usize) : nat = +let hashmap_HashMap_get_mut_in_list_loop_decreases (t : Type0) + (ls : hashmap_List_t t) (key : usize) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: decreases clause *) unfold -let hashmap_hash_map_remove_from_list_loop_decreases (t : Type0) (key : usize) - (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) + (ls : hashmap_List_t t) : nat = admit () diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.fst index 699ff3b2..be5a4ab1 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.fst @@ -8,54 +8,54 @@ open HashmapMain.Types (** [hashmap::HashMap::allocate_slots]: decreases clause *) unfold -let hashmap_hash_map_allocate_slots_loop_decreases (t : Type0) (slots : vec (hashmap_list_t t)) +let hashmap_HashMap_allocate_slots_loop_decreases (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : nat = n (** [hashmap::HashMap::clear]: decreases clause *) unfold -let hashmap_hash_map_clear_loop_decreases (t : Type0) (slots : vec (hashmap_list_t t)) +let hashmap_HashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = if i < length slots then length slots - i else 0 (** [hashmap::HashMap::insert_in_list]: decreases clause *) unfold -let hashmap_hash_map_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) - (ls : hashmap_list_t t) : hashmap_list_t t = +let hashmap_HashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) + (ls : hashmap_List_t t) : hashmap_List_t t = ls (** [hashmap::HashMap::move_elements_from_list]: decreases clause *) unfold -let hashmap_hash_map_move_elements_from_list_loop_decreases (t : Type0) - (ntable : hashmap_hash_map_t t) (ls : hashmap_list_t t) : hashmap_list_t t = +let hashmap_HashMap_move_elements_from_list_loop_decreases (t : Type0) + (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : hashmap_List_t t = ls (** [hashmap::HashMap::move_elements]: decreases clause *) unfold -let hashmap_hash_map_move_elements_loop_decreases (t : Type0) (ntable : hashmap_hash_map_t t) - (slots : vec (hashmap_list_t t)) (i : usize) : nat = +let hashmap_HashMap_move_elements_loop_decreases (t : Type0) (ntable : hashmap_HashMap_t t) + (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = if i < length slots then length slots - i else 0 (** [hashmap::HashMap::contains_key_in_list]: decreases clause *) unfold -let hashmap_hash_map_contains_key_in_list_loop_decreases (t : Type0) (key : usize) - (ls : hashmap_list_t t) : hashmap_list_t t = +let hashmap_HashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) + (ls : hashmap_List_t t) : hashmap_List_t t = ls (** [hashmap::HashMap::get_in_list]: decreases clause *) unfold -let hashmap_hash_map_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_list_t t) : - hashmap_list_t t = +let hashmap_HashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_List_t t) : + hashmap_List_t t = ls (** [hashmap::HashMap::get_mut_in_list]: decreases clause *) unfold -let hashmap_hash_map_get_mut_in_list_loop_decreases (t : Type0) - (ls : hashmap_list_t t) (key : usize) : hashmap_list_t t = +let hashmap_HashMap_get_mut_in_list_loop_decreases (t : Type0) + (ls : hashmap_List_t t) (key : usize) : hashmap_List_t t = ls (** [hashmap::HashMap::remove_from_list]: decreases clause *) unfold -let hashmap_hash_map_remove_from_list_loop_decreases (t : Type0) (key : usize) - (ls : hashmap_list_t t) : hashmap_list_t t = +let hashmap_HashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) + (ls : hashmap_List_t t) : hashmap_List_t t = ls diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index 1c94209c..5f227596 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -9,529 +9,528 @@ include HashmapMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [hashmap_main::hashmap::hash_key]: forward function *) -let hashmap_hash_key_fwd (k : usize) : result usize = +let hashmap_hash_key (k : usize) : result usize = Return k (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) -let rec hashmap_hash_map_allocate_slots_loop_fwd - (t : Type0) (slots : vec (hashmap_list_t t)) (n : usize) : - Tot (result (vec (hashmap_list_t t))) - (decreases (hashmap_hash_map_allocate_slots_loop_decreases t slots n)) +let rec hashmap_HashMap_allocate_slots_loop + (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : + Tot (result (alloc_vec_Vec (hashmap_List_t t))) + (decreases (hashmap_HashMap_allocate_slots_loop_decreases t slots n)) = if n > 0 then - let* slots0 = vec_push_back (hashmap_list_t t) slots HashmapListNil in + let* slots0 = alloc_vec_Vec_push (hashmap_List_t t) slots Hashmap_List_Nil + in let* n0 = usize_sub n 1 in - hashmap_hash_map_allocate_slots_loop_fwd t slots0 n0 + hashmap_HashMap_allocate_slots_loop t slots0 n0 else Return slots (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function *) -let hashmap_hash_map_allocate_slots_fwd - (t : Type0) (slots : vec (hashmap_list_t t)) (n : usize) : - result (vec (hashmap_list_t t)) +let hashmap_HashMap_allocate_slots + (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : + result (alloc_vec_Vec (hashmap_List_t t)) = - hashmap_hash_map_allocate_slots_loop_fwd t slots n + hashmap_HashMap_allocate_slots_loop t slots n (** [hashmap_main::hashmap::HashMap::{0}::new_with_capacity]: forward function *) -let hashmap_hash_map_new_with_capacity_fwd +let hashmap_HashMap_new_with_capacity (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : - result (hashmap_hash_map_t t) + result (hashmap_HashMap_t t) = - let v = vec_new (hashmap_list_t t) in - let* slots = hashmap_hash_map_allocate_slots_fwd t v capacity in + let v = alloc_vec_Vec_new (hashmap_List_t t) in + let* slots = hashmap_HashMap_allocate_slots t v capacity in let* i = usize_mul capacity max_load_dividend in let* i0 = usize_div i max_load_divisor in Return { - hashmap_hash_map_num_entries = 0; - hashmap_hash_map_max_load_factor = (max_load_dividend, max_load_divisor); - hashmap_hash_map_max_load = i0; - hashmap_hash_map_slots = slots + num_entries = 0; + max_load_factor = (max_load_dividend, max_load_divisor); + max_load = i0; + slots = slots } (** [hashmap_main::hashmap::HashMap::{0}::new]: forward function *) -let hashmap_hash_map_new_fwd (t : Type0) : result (hashmap_hash_map_t t) = - hashmap_hash_map_new_with_capacity_fwd t 32 4 5 +let hashmap_HashMap_new (t : Type0) : result (hashmap_HashMap_t t) = + hashmap_HashMap_new_with_capacity t 32 4 5 (** [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hashmap_hash_map_clear_loop_fwd_back - (t : Type0) (slots : vec (hashmap_list_t t)) (i : usize) : - Tot (result (vec (hashmap_list_t t))) - (decreases (hashmap_hash_map_clear_loop_decreases t slots i)) +let rec hashmap_HashMap_clear_loop + (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : + Tot (result (alloc_vec_Vec (hashmap_List_t t))) + (decreases (hashmap_HashMap_clear_loop_decreases t slots i)) = - let i0 = vec_len (hashmap_list_t t) slots in + let i0 = alloc_vec_Vec_len (hashmap_List_t t) slots in if i < i0 then let* i1 = usize_add i 1 in - let* slots0 = vec_index_mut_back (hashmap_list_t t) slots i HashmapListNil - in - hashmap_hash_map_clear_loop_fwd_back t slots0 i1 + let* slots0 = + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) slots i Hashmap_List_Nil in + hashmap_HashMap_clear_loop t slots0 i1 else Return slots (** [hashmap_main::hashmap::HashMap::{0}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_clear_fwd_back - (t : Type0) (self : hashmap_hash_map_t t) : result (hashmap_hash_map_t t) = - let* v = hashmap_hash_map_clear_loop_fwd_back t self.hashmap_hash_map_slots 0 - in - Return - { self with hashmap_hash_map_num_entries = 0; hashmap_hash_map_slots = v } +let hashmap_HashMap_clear + (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = + let* v = hashmap_HashMap_clear_loop t self.slots 0 in + Return { self with num_entries = 0; slots = v } (** [hashmap_main::hashmap::HashMap::{0}::len]: forward function *) -let hashmap_hash_map_len_fwd - (t : Type0) (self : hashmap_hash_map_t t) : result usize = - Return self.hashmap_hash_map_num_entries +let hashmap_HashMap_len + (t : Type0) (self : hashmap_HashMap_t t) : result usize = + Return self.num_entries (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) -let rec hashmap_hash_map_insert_in_list_loop_fwd - (t : Type0) (key : usize) (value : t) (ls : hashmap_list_t t) : +let rec hashmap_HashMap_insert_in_list_loop + (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : Tot (result bool) - (decreases (hashmap_hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashmap_HashMap_insert_in_list_loop_decreases t key value ls)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key then Return false - else hashmap_hash_map_insert_in_list_loop_fwd t key value tl - | HashmapListNil -> Return true + else hashmap_HashMap_insert_in_list_loop t key value tl + | Hashmap_List_Nil -> Return true end (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: forward function *) -let hashmap_hash_map_insert_in_list_fwd - (t : Type0) (key : usize) (value : t) (ls : hashmap_list_t t) : result bool = - hashmap_hash_map_insert_in_list_loop_fwd t key value ls +let hashmap_HashMap_insert_in_list + (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : result bool = + hashmap_HashMap_insert_in_list_loop t key value ls (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) -let rec hashmap_hash_map_insert_in_list_loop_back - (t : Type0) (key : usize) (value : t) (ls : hashmap_list_t t) : - Tot (result (hashmap_list_t t)) - (decreases (hashmap_hash_map_insert_in_list_loop_decreases t key value ls)) +let rec hashmap_HashMap_insert_in_list_loop_back + (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : + Tot (result (hashmap_List_t t)) + (decreases (hashmap_HashMap_insert_in_list_loop_decreases t key value ls)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key - then Return (HashmapListCons ckey value tl) + then Return (Hashmap_List_Cons ckey value tl) else - let* tl0 = hashmap_hash_map_insert_in_list_loop_back t key value tl in - Return (HashmapListCons ckey cvalue tl0) - | HashmapListNil -> - let l = HashmapListNil in Return (HashmapListCons key value l) + let* tl0 = hashmap_HashMap_insert_in_list_loop_back t key value tl in + Return (Hashmap_List_Cons ckey cvalue tl0) + | Hashmap_List_Nil -> + let l = Hashmap_List_Nil in Return (Hashmap_List_Cons key value l) end (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) -let hashmap_hash_map_insert_in_list_back - (t : Type0) (key : usize) (value : t) (ls : hashmap_list_t t) : - result (hashmap_list_t t) +let hashmap_HashMap_insert_in_list_back + (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : + result (hashmap_List_t t) = - hashmap_hash_map_insert_in_list_loop_back t key value ls + hashmap_HashMap_insert_in_list_loop_back t key value ls (** [hashmap_main::hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_insert_no_resize_fwd_back - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) (value : t) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_insert_no_resize + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (value : t) : + result (hashmap_HashMap_t t) = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - let* inserted = hashmap_hash_map_insert_in_list_fwd t key value l in + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + let* inserted = hashmap_HashMap_insert_in_list t key value l in if inserted then - let* i0 = usize_add self.hashmap_hash_map_num_entries 1 in - let* l0 = hashmap_hash_map_insert_in_list_back t key value l in + let* i0 = usize_add self.num_entries 1 in + let* l0 = hashmap_HashMap_insert_in_list_back t key value l in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots - hash_mod l0 in - Return - { self with hashmap_hash_map_num_entries = i0; hashmap_hash_map_slots = v - } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) self.slots hash_mod l0 in + Return { self with num_entries = i0; slots = v } else - let* l0 = hashmap_hash_map_insert_in_list_back t key value l in + let* l0 = hashmap_HashMap_insert_in_list_back t key value l in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots - hash_mod l0 in - Return { self with hashmap_hash_map_slots = v } - -(** [core::num::u32::{8}::MAX] *) -let core_num_u32_max_body : result u32 = Return 4294967295 -let core_num_u32_max_c : u32 = eval_global core_num_u32_max_body + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) self.slots hash_mod l0 in + Return { self with slots = v } (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hashmap_hash_map_move_elements_from_list_loop_fwd_back - (t : Type0) (ntable : hashmap_hash_map_t t) (ls : hashmap_list_t t) : - Tot (result (hashmap_hash_map_t t)) +let rec hashmap_HashMap_move_elements_from_list_loop + (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : + Tot (result (hashmap_HashMap_t t)) (decreases ( - hashmap_hash_map_move_elements_from_list_loop_decreases t ntable ls)) + hashmap_HashMap_move_elements_from_list_loop_decreases t ntable ls)) = begin match ls with - | HashmapListCons k v tl -> - let* ntable0 = hashmap_hash_map_insert_no_resize_fwd_back t ntable k v in - hashmap_hash_map_move_elements_from_list_loop_fwd_back t ntable0 tl - | HashmapListNil -> Return ntable + | Hashmap_List_Cons k v tl -> + let* ntable0 = hashmap_HashMap_insert_no_resize t ntable k v in + hashmap_HashMap_move_elements_from_list_loop t ntable0 tl + | Hashmap_List_Nil -> Return ntable end (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_move_elements_from_list_fwd_back - (t : Type0) (ntable : hashmap_hash_map_t t) (ls : hashmap_list_t t) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_move_elements_from_list + (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : + result (hashmap_HashMap_t t) = - hashmap_hash_map_move_elements_from_list_loop_fwd_back t ntable ls + hashmap_HashMap_move_elements_from_list_loop t ntable ls (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hashmap_hash_map_move_elements_loop_fwd_back - (t : Type0) (ntable : hashmap_hash_map_t t) (slots : vec (hashmap_list_t t)) - (i : usize) : - Tot (result ((hashmap_hash_map_t t) & (vec (hashmap_list_t t)))) - (decreases (hashmap_hash_map_move_elements_loop_decreases t ntable slots i)) +let rec hashmap_HashMap_move_elements_loop + (t : Type0) (ntable : hashmap_HashMap_t t) + (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : + Tot (result ((hashmap_HashMap_t t) & (alloc_vec_Vec (hashmap_List_t t)))) + (decreases (hashmap_HashMap_move_elements_loop_decreases t ntable slots i)) = - let i0 = vec_len (hashmap_list_t t) slots in + let i0 = alloc_vec_Vec_len (hashmap_List_t t) slots in if i < i0 then - let* l = vec_index_mut_fwd (hashmap_list_t t) slots i in - let ls = mem_replace_fwd (hashmap_list_t t) l HashmapListNil in - let* ntable0 = - hashmap_hash_map_move_elements_from_list_fwd_back t ntable ls in + let* l = + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) slots i in + let ls = core_mem_replace (hashmap_List_t t) l Hashmap_List_Nil in + let* ntable0 = hashmap_HashMap_move_elements_from_list t ntable ls in let* i1 = usize_add i 1 in - let l0 = mem_replace_back (hashmap_list_t t) l HashmapListNil in - let* slots0 = vec_index_mut_back (hashmap_list_t t) slots i l0 in - hashmap_hash_map_move_elements_loop_fwd_back t ntable0 slots0 i1 + let l0 = core_mem_replace_back (hashmap_List_t t) l Hashmap_List_Nil in + let* slots0 = + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) slots i l0 in + hashmap_HashMap_move_elements_loop t ntable0 slots0 i1 else Return (ntable, slots) (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_move_elements_fwd_back - (t : Type0) (ntable : hashmap_hash_map_t t) (slots : vec (hashmap_list_t t)) - (i : usize) : - result ((hashmap_hash_map_t t) & (vec (hashmap_list_t t))) +let hashmap_HashMap_move_elements + (t : Type0) (ntable : hashmap_HashMap_t t) + (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : + result ((hashmap_HashMap_t t) & (alloc_vec_Vec (hashmap_List_t t))) = - hashmap_hash_map_move_elements_loop_fwd_back t ntable slots i + hashmap_HashMap_move_elements_loop t ntable slots i (** [hashmap_main::hashmap::HashMap::{0}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_try_resize_fwd_back - (t : Type0) (self : hashmap_hash_map_t t) : result (hashmap_hash_map_t t) = - let* max_usize = scalar_cast U32 Usize core_num_u32_max_c in - let capacity = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_try_resize + (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = + let* max_usize = scalar_cast U32 Usize core_u32_max in + let capacity = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* n1 = usize_div max_usize 2 in - let (i, i0) = self.hashmap_hash_map_max_load_factor in + let (i, i0) = self.max_load_factor in let* i1 = usize_div n1 i in if capacity <= i1 then let* i2 = usize_mul capacity 2 in - let* ntable = hashmap_hash_map_new_with_capacity_fwd t i2 i i0 in - let* (ntable0, _) = - hashmap_hash_map_move_elements_fwd_back t ntable - self.hashmap_hash_map_slots 0 in + let* ntable = hashmap_HashMap_new_with_capacity t i2 i i0 in + let* (ntable0, _) = hashmap_HashMap_move_elements t ntable self.slots 0 in Return - { - ntable0 - with - hashmap_hash_map_num_entries = self.hashmap_hash_map_num_entries; - hashmap_hash_map_max_load_factor = (i, i0) + { ntable0 with num_entries = self.num_entries; max_load_factor = (i, i0) } - else Return { self with hashmap_hash_map_max_load_factor = (i, i0) } + else Return { self with max_load_factor = (i, i0) } (** [hashmap_main::hashmap::HashMap::{0}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_insert_fwd_back - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) (value : t) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_insert + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (value : t) : + result (hashmap_HashMap_t t) = - let* self0 = hashmap_hash_map_insert_no_resize_fwd_back t self key value in - let* i = hashmap_hash_map_len_fwd t self0 in - if i > self0.hashmap_hash_map_max_load - then hashmap_hash_map_try_resize_fwd_back t self0 + let* self0 = hashmap_HashMap_insert_no_resize t self key value in + let* i = hashmap_HashMap_len t self0 in + if i > self0.max_load + then hashmap_HashMap_try_resize t self0 else Return self0 (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) -let rec hashmap_hash_map_contains_key_in_list_loop_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : +let rec hashmap_HashMap_contains_key_in_list_loop + (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result bool) - (decreases (hashmap_hash_map_contains_key_in_list_loop_decreases t key ls)) + (decreases (hashmap_HashMap_contains_key_in_list_loop_decreases t key ls)) = begin match ls with - | HashmapListCons ckey x tl -> + | Hashmap_List_Cons ckey x tl -> if ckey = key then Return true - else hashmap_hash_map_contains_key_in_list_loop_fwd t key tl - | HashmapListNil -> Return false + else hashmap_HashMap_contains_key_in_list_loop t key tl + | Hashmap_List_Nil -> Return false end (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: forward function *) -let hashmap_hash_map_contains_key_in_list_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : result bool = - hashmap_hash_map_contains_key_in_list_loop_fwd t key ls +let hashmap_HashMap_contains_key_in_list + (t : Type0) (key : usize) (ls : hashmap_List_t t) : result bool = + hashmap_HashMap_contains_key_in_list_loop t key ls (** [hashmap_main::hashmap::HashMap::{0}::contains_key]: forward function *) -let hashmap_hash_map_contains_key_fwd - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : result bool = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_contains_key + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result bool = + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod in - hashmap_hash_map_contains_key_in_list_fwd t key l + alloc_vec_Vec_index (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + hashmap_HashMap_contains_key_in_list t key l (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) -let rec hashmap_hash_map_get_in_list_loop_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : +let rec hashmap_HashMap_get_in_list_loop + (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result t) - (decreases (hashmap_hash_map_get_in_list_loop_decreases t key ls)) + (decreases (hashmap_HashMap_get_in_list_loop_decreases t key ls)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key then Return cvalue - else hashmap_hash_map_get_in_list_loop_fwd t key tl - | HashmapListNil -> Fail Failure + else hashmap_HashMap_get_in_list_loop t key tl + | Hashmap_List_Nil -> Fail Failure end (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: forward function *) -let hashmap_hash_map_get_in_list_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : result t = - hashmap_hash_map_get_in_list_loop_fwd t key ls +let hashmap_HashMap_get_in_list + (t : Type0) (key : usize) (ls : hashmap_List_t t) : result t = + hashmap_HashMap_get_in_list_loop t key ls (** [hashmap_main::hashmap::HashMap::{0}::get]: forward function *) -let hashmap_hash_map_get_fwd - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : result t = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_get + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result t = + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod in - hashmap_hash_map_get_in_list_fwd t key l + alloc_vec_Vec_index (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + hashmap_HashMap_get_in_list t key l (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) -let rec hashmap_hash_map_get_mut_in_list_loop_fwd - (t : Type0) (ls : hashmap_list_t t) (key : usize) : +let rec hashmap_HashMap_get_mut_in_list_loop + (t : Type0) (ls : hashmap_List_t t) (key : usize) : Tot (result t) - (decreases (hashmap_hash_map_get_mut_in_list_loop_decreases t ls key)) + (decreases (hashmap_HashMap_get_mut_in_list_loop_decreases t ls key)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key then Return cvalue - else hashmap_hash_map_get_mut_in_list_loop_fwd t tl key - | HashmapListNil -> Fail Failure + else hashmap_HashMap_get_mut_in_list_loop t tl key + | Hashmap_List_Nil -> Fail Failure end (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: forward function *) -let hashmap_hash_map_get_mut_in_list_fwd - (t : Type0) (ls : hashmap_list_t t) (key : usize) : result t = - hashmap_hash_map_get_mut_in_list_loop_fwd t ls key +let hashmap_HashMap_get_mut_in_list + (t : Type0) (ls : hashmap_List_t t) (key : usize) : result t = + hashmap_HashMap_get_mut_in_list_loop t ls key (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) -let rec hashmap_hash_map_get_mut_in_list_loop_back - (t : Type0) (ls : hashmap_list_t t) (key : usize) (ret : t) : - Tot (result (hashmap_list_t t)) - (decreases (hashmap_hash_map_get_mut_in_list_loop_decreases t ls key)) +let rec hashmap_HashMap_get_mut_in_list_loop_back + (t : Type0) (ls : hashmap_List_t t) (key : usize) (ret : t) : + Tot (result (hashmap_List_t t)) + (decreases (hashmap_HashMap_get_mut_in_list_loop_decreases t ls key)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key - then Return (HashmapListCons ckey ret tl) + then Return (Hashmap_List_Cons ckey ret tl) else - let* tl0 = hashmap_hash_map_get_mut_in_list_loop_back t tl key ret in - Return (HashmapListCons ckey cvalue tl0) - | HashmapListNil -> Fail Failure + let* tl0 = hashmap_HashMap_get_mut_in_list_loop_back t tl key ret in + Return (Hashmap_List_Cons ckey cvalue tl0) + | Hashmap_List_Nil -> Fail Failure end (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) -let hashmap_hash_map_get_mut_in_list_back - (t : Type0) (ls : hashmap_list_t t) (key : usize) (ret : t) : - result (hashmap_list_t t) +let hashmap_HashMap_get_mut_in_list_back + (t : Type0) (ls : hashmap_List_t t) (key : usize) (ret : t) : + result (hashmap_List_t t) = - hashmap_hash_map_get_mut_in_list_loop_back t ls key ret + hashmap_HashMap_get_mut_in_list_loop_back t ls key ret (** [hashmap_main::hashmap::HashMap::{0}::get_mut]: forward function *) -let hashmap_hash_map_get_mut_fwd - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : result t = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_get_mut + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result t = + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - hashmap_hash_map_get_mut_in_list_fwd t l key + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + hashmap_HashMap_get_mut_in_list t l key (** [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 *) -let hashmap_hash_map_get_mut_back - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) (ret : t) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_get_mut_back + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (ret : t) : + result (hashmap_HashMap_t t) = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - let* l0 = hashmap_hash_map_get_mut_in_list_back t l key ret in + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + let* l0 = hashmap_HashMap_get_mut_in_list_back t l key ret in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - l0 in - Return { self with hashmap_hash_map_slots = v } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod l0 in + Return { self with slots = v } (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) -let rec hashmap_hash_map_remove_from_list_loop_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : +let rec hashmap_HashMap_remove_from_list_loop + (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result (option t)) - (decreases (hashmap_hash_map_remove_from_list_loop_decreases t key ls)) + (decreases (hashmap_HashMap_remove_from_list_loop_decreases t key ls)) = begin match ls with - | HashmapListCons ckey x tl -> + | Hashmap_List_Cons ckey x tl -> if ckey = key then let mv_ls = - mem_replace_fwd (hashmap_list_t t) (HashmapListCons ckey x tl) - HashmapListNil in + core_mem_replace (hashmap_List_t t) (Hashmap_List_Cons ckey x tl) + Hashmap_List_Nil in begin match mv_ls with - | HashmapListCons i cvalue tl0 -> Return (Some cvalue) - | HashmapListNil -> Fail Failure + | Hashmap_List_Cons i cvalue tl0 -> Return (Some cvalue) + | Hashmap_List_Nil -> Fail Failure end - else hashmap_hash_map_remove_from_list_loop_fwd t key tl - | HashmapListNil -> Return None + else hashmap_HashMap_remove_from_list_loop t key tl + | Hashmap_List_Nil -> Return None end (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function *) -let hashmap_hash_map_remove_from_list_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : result (option t) = - hashmap_hash_map_remove_from_list_loop_fwd t key ls +let hashmap_HashMap_remove_from_list + (t : Type0) (key : usize) (ls : hashmap_List_t t) : result (option t) = + hashmap_HashMap_remove_from_list_loop t key ls (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) -let rec hashmap_hash_map_remove_from_list_loop_back - (t : Type0) (key : usize) (ls : hashmap_list_t t) : - Tot (result (hashmap_list_t t)) - (decreases (hashmap_hash_map_remove_from_list_loop_decreases t key ls)) +let rec hashmap_HashMap_remove_from_list_loop_back + (t : Type0) (key : usize) (ls : hashmap_List_t t) : + Tot (result (hashmap_List_t t)) + (decreases (hashmap_HashMap_remove_from_list_loop_decreases t key ls)) = begin match ls with - | HashmapListCons ckey x tl -> + | Hashmap_List_Cons ckey x tl -> if ckey = key then let mv_ls = - mem_replace_fwd (hashmap_list_t t) (HashmapListCons ckey x tl) - HashmapListNil in + core_mem_replace (hashmap_List_t t) (Hashmap_List_Cons ckey x tl) + Hashmap_List_Nil in begin match mv_ls with - | HashmapListCons i cvalue tl0 -> Return tl0 - | HashmapListNil -> Fail Failure + | Hashmap_List_Cons i cvalue tl0 -> Return tl0 + | Hashmap_List_Nil -> Fail Failure end else - let* tl0 = hashmap_hash_map_remove_from_list_loop_back t key tl in - Return (HashmapListCons ckey x tl0) - | HashmapListNil -> Return HashmapListNil + let* tl0 = hashmap_HashMap_remove_from_list_loop_back t key tl in + Return (Hashmap_List_Cons ckey x tl0) + | Hashmap_List_Nil -> Return Hashmap_List_Nil end (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) -let hashmap_hash_map_remove_from_list_back - (t : Type0) (key : usize) (ls : hashmap_list_t t) : - result (hashmap_list_t t) +let hashmap_HashMap_remove_from_list_back + (t : Type0) (key : usize) (ls : hashmap_List_t t) : + result (hashmap_List_t t) = - hashmap_hash_map_remove_from_list_loop_back t key ls + hashmap_HashMap_remove_from_list_loop_back t key ls (** [hashmap_main::hashmap::HashMap::{0}::remove]: forward function *) -let hashmap_hash_map_remove_fwd - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : result (option t) = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_remove + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result (option t) = + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - let* x = hashmap_hash_map_remove_from_list_fwd t key l in + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + let* x = hashmap_HashMap_remove_from_list t key l in begin match x with | None -> Return None - | Some x0 -> - let* _ = usize_sub self.hashmap_hash_map_num_entries 1 in Return (Some x0) + | Some x0 -> let* _ = usize_sub self.num_entries 1 in Return (Some x0) end (** [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 *) -let hashmap_hash_map_remove_back - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_remove_back + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : + result (hashmap_HashMap_t t) = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - let* x = hashmap_hash_map_remove_from_list_fwd t key l in + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + let* x = hashmap_HashMap_remove_from_list t key l in begin match x with | None -> - let* l0 = hashmap_hash_map_remove_from_list_back t key l in + let* l0 = hashmap_HashMap_remove_from_list_back t key l in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots - hash_mod l0 in - Return { self with hashmap_hash_map_slots = v } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) self.slots hash_mod l0 in + Return { self with slots = v } | Some x0 -> - let* i0 = usize_sub self.hashmap_hash_map_num_entries 1 in - let* l0 = hashmap_hash_map_remove_from_list_back t key l in + let* i0 = usize_sub self.num_entries 1 in + let* l0 = hashmap_HashMap_remove_from_list_back t key l in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots - hash_mod l0 in - Return - { self with hashmap_hash_map_num_entries = i0; hashmap_hash_map_slots = v - } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) self.slots hash_mod l0 in + Return { self with num_entries = i0; slots = v } end (** [hashmap_main::hashmap::test1]: forward function *) -let hashmap_test1_fwd : result unit = - let* hm = hashmap_hash_map_new_fwd u64 in - let* hm0 = hashmap_hash_map_insert_fwd_back u64 hm 0 42 in - let* hm1 = hashmap_hash_map_insert_fwd_back u64 hm0 128 18 in - let* hm2 = hashmap_hash_map_insert_fwd_back u64 hm1 1024 138 in - let* hm3 = hashmap_hash_map_insert_fwd_back u64 hm2 1056 256 in - let* i = hashmap_hash_map_get_fwd u64 hm3 128 in +let hashmap_test1 : result unit = + let* hm = hashmap_HashMap_new u64 in + let* hm0 = hashmap_HashMap_insert u64 hm 0 42 in + let* hm1 = hashmap_HashMap_insert u64 hm0 128 18 in + let* hm2 = hashmap_HashMap_insert u64 hm1 1024 138 in + let* hm3 = hashmap_HashMap_insert u64 hm2 1056 256 in + let* i = hashmap_HashMap_get u64 hm3 128 in if not (i = 18) then Fail Failure else - let* hm4 = hashmap_hash_map_get_mut_back u64 hm3 1024 56 in - let* i0 = hashmap_hash_map_get_fwd u64 hm4 1024 in + let* hm4 = hashmap_HashMap_get_mut_back u64 hm3 1024 56 in + let* i0 = hashmap_HashMap_get u64 hm4 1024 in if not (i0 = 56) then Fail Failure else - let* x = hashmap_hash_map_remove_fwd u64 hm4 1024 in + let* x = hashmap_HashMap_remove u64 hm4 1024 in begin match x with | None -> Fail Failure | Some x0 -> if not (x0 = 56) then Fail Failure else - let* hm5 = hashmap_hash_map_remove_back u64 hm4 1024 in - let* i1 = hashmap_hash_map_get_fwd u64 hm5 0 in + let* hm5 = hashmap_HashMap_remove_back u64 hm4 1024 in + let* i1 = hashmap_HashMap_get u64 hm5 0 in if not (i1 = 42) then Fail Failure else - let* i2 = hashmap_hash_map_get_fwd u64 hm5 128 in + let* i2 = hashmap_HashMap_get u64 hm5 128 in if not (i2 = 18) then Fail Failure else - let* i3 = hashmap_hash_map_get_fwd u64 hm5 1056 in + let* i3 = hashmap_HashMap_get u64 hm5 1056 in if not (i3 = 256) then Fail Failure else Return () end -(** Unit test for [hashmap_main::hashmap::test1] *) -let _ = assert_norm (hashmap_test1_fwd = Return ()) - (** [hashmap_main::insert_on_disk]: forward function *) -let insert_on_disk_fwd +let insert_on_disk (key : usize) (value : u64) (st : state) : result (state & unit) = - let* (st0, hm) = hashmap_utils_deserialize_fwd st in - let* hm0 = hashmap_hash_map_insert_fwd_back u64 hm key value in - let* (st1, _) = hashmap_utils_serialize_fwd hm0 st0 in + let* (st0, hm) = hashmap_utils_deserialize st in + let* hm0 = hashmap_HashMap_insert u64 hm key value in + let* (st1, _) = hashmap_utils_serialize hm0 st0 in Return (st1, ()) (** [hashmap_main::main]: forward function *) -let main_fwd : result unit = +let main : result unit = Return () -(** Unit test for [hashmap_main::main] *) -let _ = assert_norm (main_fwd = Return ()) - diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti index 78a6c3ba..d6cecf36 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti @@ -7,10 +7,10 @@ include HashmapMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [hashmap_main::hashmap_utils::deserialize]: forward function *) -val hashmap_utils_deserialize_fwd - : state -> result (state & (hashmap_hash_map_t u64)) +val hashmap_utils_deserialize + : state -> result (state & (hashmap_HashMap_t u64)) (** [hashmap_main::hashmap_utils::serialize]: forward function *) -val hashmap_utils_serialize_fwd - : hashmap_hash_map_t u64 -> state -> result (state & unit) +val hashmap_utils_serialize + : hashmap_HashMap_t u64 -> state -> result (state & unit) diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Properties.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Properties.fst index 106fe05a..358df29e 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Properties.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Properties.fst @@ -13,36 +13,36 @@ open HashmapMain.Funs /// [state_v] gives us the hash map currently stored on disk assume -val state_v : state -> hashmap_hash_map_t u64 +val state_v : state -> hashmap_HashMap_t u64 /// [serialize] updates the hash map stored on disk assume -val serialize_lem (hm : hashmap_hash_map_t u64) (st : state) : Lemma ( - match hashmap_utils_serialize_fwd hm st with +val serialize_lem (hm : hashmap_HashMap_t u64) (st : state) : Lemma ( + match hashmap_utils_serialize hm st with | Fail _ -> True | Return (st', ()) -> state_v st' == hm) - [SMTPat (hashmap_utils_serialize_fwd hm st)] + [SMTPat (hashmap_utils_serialize hm st)] /// [deserialize] gives us the hash map stored on disk, without updating it assume val deserialize_lem (st : state) : Lemma ( - match hashmap_utils_deserialize_fwd st with + match hashmap_utils_deserialize st with | Fail _ -> True | Return (st', hm) -> hm == state_v st /\ st' == st) - [SMTPat (hashmap_utils_deserialize_fwd st)] + [SMTPat (hashmap_utils_deserialize st)] (*** Lemmas *) /// The obvious lemma about [insert_on_disk]: the updated hash map stored on disk /// is exactly the hash map produced from inserting the binding ([key], [value]) /// in the hash map previously stored on disk. -val insert_on_disk_fwd_lem (key : usize) (value : u64) (st : state) : Lemma ( - match insert_on_disk_fwd key value st with +val insert_on_disk_lem (key : usize) (value : u64) (st : state) : Lemma ( + match insert_on_disk key value st with | Fail _ -> True | Return (st', ()) -> let hm = state_v st in - match hashmap_hash_map_insert_fwd_back u64 hm key value with + match hashmap_HashMap_insert u64 hm key value with | Fail _ -> False | Return hm' -> hm' == state_v st') -let insert_on_disk_fwd_lem key value st = () +let insert_on_disk_lem key value st = () diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti index e289174b..24b78c2a 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti @@ -6,17 +6,17 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [hashmap_main::hashmap::List] *) -type hashmap_list_t (t : Type0) = -| HashmapListCons : usize -> t -> hashmap_list_t t -> hashmap_list_t t -| HashmapListNil : hashmap_list_t t +type hashmap_List_t (t : Type0) = +| Hashmap_List_Cons : usize -> t -> hashmap_List_t t -> hashmap_List_t t +| Hashmap_List_Nil : hashmap_List_t t (** [hashmap_main::hashmap::HashMap] *) -type hashmap_hash_map_t (t : Type0) = +type hashmap_HashMap_t (t : Type0) = { - hashmap_hash_map_num_entries : usize; - hashmap_hash_map_max_load_factor : (usize & usize); - hashmap_hash_map_max_load : usize; - hashmap_hash_map_slots : vec (hashmap_list_t t); + num_entries : usize; + max_load_factor : (usize & usize); + max_load : usize; + slots : alloc_vec_Vec (hashmap_List_t t); } (** The state type used in the state-error monad *) diff --git a/tests/fstar/hashmap_on_disk/Primitives.fst b/tests/fstar/hashmap_on_disk/Primitives.fst index 9db82069..3297803c 100644 --- a/tests/fstar/hashmap_on_disk/Primitives.fst +++ b/tests/fstar/hashmap_on_disk/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -169,17 +187,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize @@ -231,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -259,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -278,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -295,55 +389,54 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -358,18 +451,279 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/misc/Constants.fst b/tests/fstar/misc/Constants.fst index d2b0415e..c21d6a5f 100644 --- a/tests/fstar/misc/Constants.fst +++ b/tests/fstar/misc/Constants.fst @@ -9,12 +9,8 @@ open Primitives let x0_body : result u32 = Return 0 let x0_c : u32 = eval_global x0_body -(** [core::num::u32::{8}::MAX] *) -let core_num_u32_max_body : result u32 = Return 4294967295 -let core_num_u32_max_c : u32 = eval_global core_num_u32_max_body - (** [constants::X1] *) -let x1_body : result u32 = Return core_num_u32_max_c +let x1_body : result u32 = Return core_u32_max let x1_c : u32 = eval_global x1_body (** [constants::X2] *) @@ -22,30 +18,30 @@ let x2_body : result u32 = Return 3 let x2_c : u32 = eval_global x2_body (** [constants::incr]: forward function *) -let incr_fwd (n : u32) : result u32 = +let incr (n : u32) : result u32 = u32_add n 1 (** [constants::X3] *) -let x3_body : result u32 = incr_fwd 32 +let x3_body : result u32 = incr 32 let x3_c : u32 = eval_global x3_body (** [constants::mk_pair0]: forward function *) -let mk_pair0_fwd (x : u32) (y : u32) : result (u32 & u32) = +let mk_pair0 (x : u32) (y : u32) : result (u32 & u32) = Return (x, y) (** [constants::Pair] *) -type pair_t (t1 t2 : Type0) = { pair_x : t1; pair_y : t2; } +type pair_t (t1 t2 : Type0) = { x : t1; y : t2; } (** [constants::mk_pair1]: forward function *) -let mk_pair1_fwd (x : u32) (y : u32) : result (pair_t u32 u32) = - Return { pair_x = x; pair_y = y } +let mk_pair1 (x : u32) (y : u32) : result (pair_t u32 u32) = + Return { x = x; y = y } (** [constants::P0] *) -let p0_body : result (u32 & u32) = mk_pair0_fwd 0 1 +let p0_body : result (u32 & u32) = mk_pair0 0 1 let p0_c : (u32 & u32) = eval_global p0_body (** [constants::P1] *) -let p1_body : result (pair_t u32 u32) = mk_pair1_fwd 0 1 +let p1_body : result (pair_t u32 u32) = mk_pair1 0 1 let p1_c : pair_t u32 u32 = eval_global p1_body (** [constants::P2] *) @@ -53,26 +49,26 @@ let p2_body : result (u32 & u32) = Return (0, 1) let p2_c : (u32 & u32) = eval_global p2_body (** [constants::P3] *) -let p3_body : result (pair_t u32 u32) = Return { pair_x = 0; pair_y = 1 } +let p3_body : result (pair_t u32 u32) = Return { x = 0; y = 1 } let p3_c : pair_t u32 u32 = eval_global p3_body (** [constants::Wrap] *) -type wrap_t (t : Type0) = { wrap_val : t; } +type wrap_t (t : Type0) = { value : t; } (** [constants::Wrap::{0}::new]: forward function *) -let wrap_new_fwd (t : Type0) (val0 : t) : result (wrap_t t) = - Return { wrap_val = val0 } +let wrap_new (t : Type0) (value : t) : result (wrap_t t) = + Return { value = value } (** [constants::Y] *) -let y_body : result (wrap_t i32) = wrap_new_fwd i32 2 +let y_body : result (wrap_t i32) = wrap_new i32 2 let y_c : wrap_t i32 = eval_global y_body (** [constants::unwrap_y]: forward function *) -let unwrap_y_fwd : result i32 = - Return y_c.wrap_val +let unwrap_y : result i32 = + Return y_c.value (** [constants::YVAL] *) -let yval_body : result i32 = unwrap_y_fwd +let yval_body : result i32 = unwrap_y let yval_c : i32 = eval_global yval_body (** [constants::get_z1::Z1] *) @@ -80,11 +76,11 @@ let get_z1_z1_body : result i32 = Return 3 let get_z1_z1_c : i32 = eval_global get_z1_z1_body (** [constants::get_z1]: forward function *) -let get_z1_fwd : result i32 = +let get_z1 : result i32 = Return get_z1_z1_c (** [constants::add]: forward function *) -let add_fwd (a : i32) (b : i32) : result i32 = +let add (a : i32) (b : i32) : result i32 = i32_add a b (** [constants::Q1] *) @@ -96,19 +92,19 @@ let q2_body : result i32 = Return q1_c let q2_c : i32 = eval_global q2_body (** [constants::Q3] *) -let q3_body : result i32 = add_fwd q2_c 3 +let q3_body : result i32 = add q2_c 3 let q3_c : i32 = eval_global q3_body (** [constants::get_z2]: forward function *) -let get_z2_fwd : result i32 = - let* i = get_z1_fwd in let* i0 = add_fwd i q3_c in add_fwd q1_c i0 +let get_z2 : result i32 = + let* i = get_z1 in let* i0 = add i q3_c in add q1_c i0 (** [constants::S1] *) let s1_body : result u32 = Return 6 let s1_c : u32 = eval_global s1_body (** [constants::S2] *) -let s2_body : result u32 = incr_fwd s1_c +let s2_body : result u32 = incr s1_c let s2_c : u32 = eval_global s2_body (** [constants::S3] *) @@ -116,6 +112,6 @@ let s3_body : result (pair_t u32 u32) = Return p3_c let s3_c : pair_t u32 u32 = eval_global s3_body (** [constants::S4] *) -let s4_body : result (pair_t u32 u32) = mk_pair1_fwd 7 8 +let s4_body : result (pair_t u32 u32) = mk_pair1 7 8 let s4_c : pair_t u32 u32 = eval_global s4_body diff --git a/tests/fstar/misc/External.Funs.fst b/tests/fstar/misc/External.Funs.fst index f118a2cf..e26014ac 100644 --- a/tests/fstar/misc/External.Funs.fst +++ b/tests/fstar/misc/External.Funs.fst @@ -8,8 +8,8 @@ include External.Opaque #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [external::swap]: forward function *) -let swap_fwd (t : Type0) (x : t) (y : t) (st : state) : result (state & unit) = - let* (st0, _) = core_mem_swap_fwd t x y st in +let swap (t : Type0) (x : t) (y : t) (st : state) : result (state & unit) = + let* (st0, _) = core_mem_swap t x y st in let* (st1, _) = core_mem_swap_back0 t x y st st0 in let* (st2, _) = core_mem_swap_back1 t x y st st1 in Return (st2, ()) @@ -19,28 +19,29 @@ let swap_back (t : Type0) (x : t) (y : t) (st : state) (st0 : state) : result (state & (t & t)) = - let* (st1, _) = core_mem_swap_fwd t x y st in + let* (st1, _) = core_mem_swap t x y st in let* (st2, x0) = core_mem_swap_back0 t x y st st1 in let* (_, y0) = core_mem_swap_back1 t x y st st2 in Return (st0, (x0, y0)) (** [external::test_new_non_zero_u32]: forward function *) -let test_new_non_zero_u32_fwd - (x : u32) (st : state) : result (state & core_num_nonzero_non_zero_u32_t) = - let* (st0, opt) = core_num_nonzero_non_zero_u32_new_fwd x st in - core_option_option_unwrap_fwd core_num_nonzero_non_zero_u32_t opt st0 +let test_new_non_zero_u32 + (x : u32) (st : state) : result (state & core_num_nonzero_NonZeroU32_t) = + let* (st0, o) = core_num_nonzero_NonZeroU32_new x st in + core_option_Option_unwrap core_num_nonzero_NonZeroU32_t o st0 (** [external::test_vec]: forward function *) -let test_vec_fwd : result unit = - let v = vec_new u32 in let* _ = vec_push_back u32 v 0 in Return () +let test_vec : result unit = + let v = alloc_vec_Vec_new u32 in + let* _ = alloc_vec_Vec_push u32 v 0 in + Return () (** Unit test for [external::test_vec] *) -let _ = assert_norm (test_vec_fwd = Return ()) +let _ = assert_norm (test_vec = Return ()) (** [external::custom_swap]: forward function *) -let custom_swap_fwd - (t : Type0) (x : t) (y : t) (st : state) : result (state & t) = - let* (st0, _) = core_mem_swap_fwd t x y st in +let custom_swap (t : Type0) (x : t) (y : t) (st : state) : result (state & t) = + let* (st0, _) = core_mem_swap t x y st in let* (st1, x0) = core_mem_swap_back0 t x y st st0 in let* (st2, _) = core_mem_swap_back1 t x y st st1 in Return (st2, x0) @@ -50,15 +51,14 @@ let custom_swap_back (t : Type0) (x : t) (y : t) (st : state) (ret : t) (st0 : state) : result (state & (t & t)) = - let* (st1, _) = core_mem_swap_fwd t x y st in + let* (st1, _) = core_mem_swap t x y st in let* (st2, _) = core_mem_swap_back0 t x y st st1 in let* (_, y0) = core_mem_swap_back1 t x y st st2 in Return (st0, (ret, y0)) (** [external::test_custom_swap]: forward function *) -let test_custom_swap_fwd - (x : u32) (y : u32) (st : state) : result (state & unit) = - let* (st0, _) = custom_swap_fwd u32 x y st in Return (st0, ()) +let test_custom_swap (x : u32) (y : u32) (st : state) : result (state & unit) = + let* (st0, _) = custom_swap u32 x y st in Return (st0, ()) (** [external::test_custom_swap]: backward function 0 *) let test_custom_swap_back @@ -68,8 +68,8 @@ let test_custom_swap_back custom_swap_back u32 x y st 1 st0 (** [external::test_swap_non_zero]: forward function *) -let test_swap_non_zero_fwd (x : u32) (st : state) : result (state & u32) = - let* (st0, _) = swap_fwd u32 x 0 st in +let test_swap_non_zero (x : u32) (st : state) : result (state & u32) = + let* (st0, _) = swap u32 x 0 st in let* (st1, (x0, _)) = swap_back u32 x 0 st st0 in if x0 = 0 then Fail Failure else Return (st1, x0) diff --git a/tests/fstar/misc/External.Opaque.fsti b/tests/fstar/misc/External.Opaque.fsti index 2e19f767..85cf285c 100644 --- a/tests/fstar/misc/External.Opaque.fsti +++ b/tests/fstar/misc/External.Opaque.fsti @@ -7,7 +7,7 @@ include External.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [core::mem::swap]: forward function *) -val core_mem_swap_fwd (t : Type0) : t -> t -> state -> result (state & unit) +val core_mem_swap (t : Type0) : t -> t -> state -> result (state & unit) (** [core::mem::swap]: backward function 0 *) val core_mem_swap_back0 @@ -18,10 +18,10 @@ val core_mem_swap_back1 (t : Type0) : t -> t -> state -> state -> result (state & t) (** [core::num::nonzero::NonZeroU32::{14}::new]: forward function *) -val core_num_nonzero_non_zero_u32_new_fwd - : u32 -> state -> result (state & (option core_num_nonzero_non_zero_u32_t)) +val core_num_nonzero_NonZeroU32_new + : u32 -> state -> result (state & (option core_num_nonzero_NonZeroU32_t)) (** [core::option::Option::{0}::unwrap]: forward function *) -val core_option_option_unwrap_fwd +val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/misc/External.Types.fsti b/tests/fstar/misc/External.Types.fsti index 4a13a744..78b5228d 100644 --- a/tests/fstar/misc/External.Types.fsti +++ b/tests/fstar/misc/External.Types.fsti @@ -6,7 +6,7 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [core::num::nonzero::NonZeroU32] *) -val core_num_nonzero_non_zero_u32_t : Type0 +val core_num_nonzero_NonZeroU32_t : Type0 (** The state type used in the state-error monad *) val state : Type0 diff --git a/tests/fstar/misc/Loops.Clauses.Template.fst b/tests/fstar/misc/Loops.Clauses.Template.fst index 053b7663..9920bdc1 100644 --- a/tests/fstar/misc/Loops.Clauses.Template.fst +++ b/tests/fstar/misc/Loops.Clauses.Template.fst @@ -22,7 +22,8 @@ let sum_with_shared_borrows_loop_decreases (max : u32) (i : u32) (s : u32) : admit () (** [loops::clear]: decreases clause *) -unfold let clear_loop_decreases (v : vec u32) (i : usize) : nat = admit () +unfold +let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = admit () (** [loops::list_mem]: decreases clause *) unfold let list_mem_loop_decreases (x : u32) (ls : list_t u32) : nat = admit () diff --git a/tests/fstar/misc/Loops.Clauses.fst b/tests/fstar/misc/Loops.Clauses.fst index 82f34de1..75194437 100644 --- a/tests/fstar/misc/Loops.Clauses.fst +++ b/tests/fstar/misc/Loops.Clauses.fst @@ -20,7 +20,7 @@ let sum_with_shared_borrows_loop_decreases (max : u32) (i : u32) (s : u32) : nat if max >= i then max - i else 0 (** [loops::clear]: decreases clause *) -unfold let clear_loop_decreases (v : vec u32) (i : usize) : nat = +unfold let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = if i <= List.Tot.length v then List.Tot.length v - i else 0 (** [loops::list_mem]: decreases clause *) diff --git a/tests/fstar/misc/Loops.Funs.fst b/tests/fstar/misc/Loops.Funs.fst index 9a80f415..0f755351 100644 --- a/tests/fstar/misc/Loops.Funs.fst +++ b/tests/fstar/misc/Loops.Funs.fst @@ -8,20 +8,20 @@ include Loops.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [loops::sum]: loop 0: forward function *) -let rec sum_loop_fwd +let rec sum_loop (max : u32) (i : u32) (s : u32) : Tot (result u32) (decreases (sum_loop_decreases max i s)) = if i < max - then let* s0 = u32_add s i in let* i0 = u32_add i 1 in sum_loop_fwd max i0 s0 + then let* s0 = u32_add s i in let* i0 = u32_add i 1 in sum_loop max i0 s0 else u32_mul s 2 (** [loops::sum]: forward function *) -let sum_fwd (max : u32) : result u32 = - sum_loop_fwd max 0 0 +let sum (max : u32) : result u32 = + sum_loop max 0 0 (** [loops::sum_with_mut_borrows]: loop 0: forward function *) -let rec sum_with_mut_borrows_loop_fwd +let rec sum_with_mut_borrows_loop (max : u32) (mi : u32) (ms : u32) : Tot (result u32) (decreases (sum_with_mut_borrows_loop_decreases max mi ms)) = @@ -29,15 +29,15 @@ let rec sum_with_mut_borrows_loop_fwd then let* ms0 = u32_add ms mi in let* mi0 = u32_add mi 1 in - sum_with_mut_borrows_loop_fwd max mi0 ms0 + sum_with_mut_borrows_loop max mi0 ms0 else u32_mul ms 2 (** [loops::sum_with_mut_borrows]: forward function *) -let sum_with_mut_borrows_fwd (max : u32) : result u32 = - sum_with_mut_borrows_loop_fwd max 0 0 +let sum_with_mut_borrows (max : u32) : result u32 = + sum_with_mut_borrows_loop max 0 0 (** [loops::sum_with_shared_borrows]: loop 0: forward function *) -let rec sum_with_shared_borrows_loop_fwd +let rec sum_with_shared_borrows_loop (max : u32) (i : u32) (s : u32) : Tot (result u32) (decreases (sum_with_shared_borrows_loop_decreases max i s)) = @@ -45,62 +45,64 @@ let rec sum_with_shared_borrows_loop_fwd then let* i0 = u32_add i 1 in let* s0 = u32_add s i0 in - sum_with_shared_borrows_loop_fwd max i0 s0 + sum_with_shared_borrows_loop max i0 s0 else u32_mul s 2 (** [loops::sum_with_shared_borrows]: forward function *) -let sum_with_shared_borrows_fwd (max : u32) : result u32 = - sum_with_shared_borrows_loop_fwd max 0 0 +let sum_with_shared_borrows (max : u32) : result u32 = + sum_with_shared_borrows_loop max 0 0 (** [loops::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec clear_loop_fwd_back - (v : vec u32) (i : usize) : - Tot (result (vec u32)) (decreases (clear_loop_decreases v i)) +let rec clear_loop + (v : alloc_vec_Vec u32) (i : usize) : + Tot (result (alloc_vec_Vec u32)) (decreases (clear_loop_decreases v i)) = - let i0 = vec_len u32 v in + let i0 = alloc_vec_Vec_len u32 v in if i < i0 then let* i1 = usize_add i 1 in - let* v0 = vec_index_mut_back u32 v i 0 in - clear_loop_fwd_back v0 i1 + let* v0 = + alloc_vec_Vec_index_mut_back u32 usize + (core_slice_index_usize_coresliceindexSliceIndexInst u32) v i 0 in + clear_loop v0 i1 else Return v (** [loops::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let clear_fwd_back (v : vec u32) : result (vec u32) = - clear_loop_fwd_back v 0 +let clear (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) = + clear_loop v 0 (** [loops::list_mem]: loop 0: forward function *) -let rec list_mem_loop_fwd +let rec list_mem_loop (x : u32) (ls : list_t u32) : Tot (result bool) (decreases (list_mem_loop_decreases x ls)) = begin match ls with - | ListCons y tl -> if y = x then Return true else list_mem_loop_fwd x tl - | ListNil -> Return false + | List_Cons y tl -> if y = x then Return true else list_mem_loop x tl + | List_Nil -> Return false end (** [loops::list_mem]: forward function *) -let list_mem_fwd (x : u32) (ls : list_t u32) : result bool = - list_mem_loop_fwd x ls +let list_mem (x : u32) (ls : list_t u32) : result bool = + list_mem_loop x ls (** [loops::list_nth_mut_loop]: loop 0: forward function *) -let rec list_nth_mut_loop_loop_fwd +let rec list_nth_mut_loop_loop (t : Type0) (ls : list_t t) (i : u32) : Tot (result t) (decreases (list_nth_mut_loop_loop_decreases t ls i)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_loop_loop_fwd t tl i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_mut_loop_loop t tl i0 + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop]: forward function *) -let list_nth_mut_loop_fwd (t : Type0) (ls : list_t t) (i : u32) : result t = - list_nth_mut_loop_loop_fwd t ls i +let list_nth_mut_loop (t : Type0) (ls : list_t t) (i : u32) : result t = + list_nth_mut_loop_loop t ls i (** [loops::list_nth_mut_loop]: loop 0: backward function 0 *) let rec list_nth_mut_loop_loop_back @@ -108,14 +110,14 @@ let rec list_nth_mut_loop_loop_back Tot (result (list_t t)) (decreases (list_nth_mut_loop_loop_decreases t ls i)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else let* i0 = u32_sub i 1 in let* tl0 = list_nth_mut_loop_loop_back t tl i0 ret in - Return (ListCons x tl0) - | ListNil -> Fail Failure + Return (List_Cons x tl0) + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop]: backward function 0 *) @@ -124,36 +126,40 @@ let list_nth_mut_loop_back list_nth_mut_loop_loop_back t ls i ret (** [loops::list_nth_shared_loop]: loop 0: forward function *) -let rec list_nth_shared_loop_loop_fwd +let rec list_nth_shared_loop_loop (t : Type0) (ls : list_t t) (i : u32) : Tot (result t) (decreases (list_nth_shared_loop_loop_decreases t ls i)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_shared_loop_loop_fwd t tl i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_shared_loop_loop t tl i0 + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_loop]: forward function *) -let list_nth_shared_loop_fwd (t : Type0) (ls : list_t t) (i : u32) : result t = - list_nth_shared_loop_loop_fwd t ls i +let list_nth_shared_loop (t : Type0) (ls : list_t t) (i : u32) : result t = + list_nth_shared_loop_loop t ls i (** [loops::get_elem_mut]: loop 0: forward function *) -let rec get_elem_mut_loop_fwd +let rec get_elem_mut_loop (x : usize) (ls : list_t usize) : Tot (result usize) (decreases (get_elem_mut_loop_decreases x ls)) = begin match ls with - | ListCons y tl -> if y = x then Return y else get_elem_mut_loop_fwd x tl - | ListNil -> Fail Failure + | List_Cons y tl -> if y = x then Return y else get_elem_mut_loop x tl + | List_Nil -> Fail Failure end (** [loops::get_elem_mut]: forward function *) -let get_elem_mut_fwd (slots : vec (list_t usize)) (x : usize) : result usize = - let* l = vec_index_mut_fwd (list_t usize) slots 0 in - get_elem_mut_loop_fwd x l +let get_elem_mut + (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = + let* l = + alloc_vec_Vec_index_mut (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in + get_elem_mut_loop x l (** [loops::get_elem_mut]: loop 0: backward function 0 *) let rec get_elem_mut_loop_back @@ -161,39 +167,48 @@ let rec get_elem_mut_loop_back Tot (result (list_t usize)) (decreases (get_elem_mut_loop_decreases x ls)) = begin match ls with - | ListCons y tl -> + | List_Cons y tl -> if y = x - then Return (ListCons ret tl) - else let* tl0 = get_elem_mut_loop_back x tl ret in Return (ListCons y tl0) - | ListNil -> Fail Failure + then Return (List_Cons ret tl) + else let* tl0 = get_elem_mut_loop_back x tl ret in Return (List_Cons y tl0) + | List_Nil -> Fail Failure end (** [loops::get_elem_mut]: backward function 0 *) let get_elem_mut_back - (slots : vec (list_t usize)) (x : usize) (ret : usize) : - result (vec (list_t usize)) + (slots : alloc_vec_Vec (list_t usize)) (x : usize) (ret : usize) : + result (alloc_vec_Vec (list_t usize)) = - let* l = vec_index_mut_fwd (list_t usize) slots 0 in + let* l = + alloc_vec_Vec_index_mut (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in let* l0 = get_elem_mut_loop_back x l ret in - vec_index_mut_back (list_t usize) slots 0 l0 + alloc_vec_Vec_index_mut_back (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) slots + 0 l0 (** [loops::get_elem_shared]: loop 0: forward function *) -let rec get_elem_shared_loop_fwd +let rec get_elem_shared_loop (x : usize) (ls : list_t usize) : Tot (result usize) (decreases (get_elem_shared_loop_decreases x ls)) = begin match ls with - | ListCons y tl -> if y = x then Return y else get_elem_shared_loop_fwd x tl - | ListNil -> Fail Failure + | List_Cons y tl -> if y = x then Return y else get_elem_shared_loop x tl + | List_Nil -> Fail Failure end (** [loops::get_elem_shared]: forward function *) -let get_elem_shared_fwd - (slots : vec (list_t usize)) (x : usize) : result usize = - let* l = vec_index_fwd (list_t usize) slots 0 in get_elem_shared_loop_fwd x l +let get_elem_shared + (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = + let* l = + alloc_vec_Vec_index (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in + get_elem_shared_loop x l (** [loops::id_mut]: forward function *) -let id_mut_fwd (t : Type0) (ls : list_t t) : result (list_t t) = +let id_mut (t : Type0) (ls : list_t t) : result (list_t t) = Return ls (** [loops::id_mut]: backward function 0 *) @@ -202,26 +217,26 @@ let id_mut_back Return ret (** [loops::id_shared]: forward function *) -let id_shared_fwd (t : Type0) (ls : list_t t) : result (list_t t) = +let id_shared (t : Type0) (ls : list_t t) : result (list_t t) = Return ls (** [loops::list_nth_mut_loop_with_id]: loop 0: forward function *) -let rec list_nth_mut_loop_with_id_loop_fwd +let rec list_nth_mut_loop_with_id_loop (t : Type0) (i : u32) (ls : list_t t) : Tot (result t) (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_loop_with_id_loop_fwd t i0 tl - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_mut_loop_with_id_loop t i0 tl + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_with_id]: forward function *) -let list_nth_mut_loop_with_id_fwd +let list_nth_mut_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result t = - let* ls0 = id_mut_fwd t ls in list_nth_mut_loop_with_id_loop_fwd t i ls0 + let* ls0 = id_mut t ls in list_nth_mut_loop_with_id_loop t i ls0 (** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 *) let rec list_nth_mut_loop_with_id_loop_back @@ -230,66 +245,64 @@ let rec list_nth_mut_loop_with_id_loop_back (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else let* i0 = u32_sub i 1 in let* tl0 = list_nth_mut_loop_with_id_loop_back t i0 tl ret in - Return (ListCons x tl0) - | ListNil -> Fail Failure + Return (List_Cons x tl0) + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_with_id]: backward function 0 *) let list_nth_mut_loop_with_id_back (t : Type0) (ls : list_t t) (i : u32) (ret : t) : result (list_t t) = - let* ls0 = id_mut_fwd t ls in + let* ls0 = id_mut t ls in let* l = list_nth_mut_loop_with_id_loop_back t i ls0 ret in id_mut_back t ls l (** [loops::list_nth_shared_loop_with_id]: loop 0: forward function *) -let rec list_nth_shared_loop_with_id_loop_fwd +let rec list_nth_shared_loop_with_id_loop (t : Type0) (i : u32) (ls : list_t t) : Tot (result t) (decreases (list_nth_shared_loop_with_id_loop_decreases t i ls)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_shared_loop_with_id_loop_fwd t i0 tl - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_shared_loop_with_id_loop t i0 tl + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_loop_with_id]: forward function *) -let list_nth_shared_loop_with_id_fwd +let list_nth_shared_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result t = - let* ls0 = id_shared_fwd t ls in - list_nth_shared_loop_with_id_loop_fwd t i ls0 + let* ls0 = id_shared t ls in list_nth_shared_loop_with_id_loop t i ls0 (** [loops::list_nth_mut_loop_pair]: loop 0: forward function *) -let rec list_nth_mut_loop_pair_loop_fwd +let rec list_nth_mut_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) - else - let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair]: forward function *) -let list_nth_mut_loop_pair_fwd +let list_nth_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_loop_pair_loop_fwd t ls0 ls1 i + list_nth_mut_loop_pair_loop t ls0 ls1 i (** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 *) let rec list_nth_mut_loop_pair_loop_back'a @@ -298,18 +311,18 @@ let rec list_nth_mut_loop_pair_loop_back'a (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else let* i0 = u32_sub i 1 in let* tl00 = list_nth_mut_loop_pair_loop_back'a t tl0 tl1 i0 ret in - Return (ListCons x0 tl00) - | ListNil -> Fail Failure + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair]: backward function 0 *) @@ -326,18 +339,18 @@ let rec list_nth_mut_loop_pair_loop_back'b (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else let* i0 = u32_sub i 1 in let* tl10 = list_nth_mut_loop_pair_loop_back'b t tl0 tl1 i0 ret in - Return (ListCons x1 tl10) - | ListNil -> Fail Failure + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair]: backward function 1 *) @@ -348,54 +361,51 @@ let list_nth_mut_loop_pair_back'b list_nth_mut_loop_pair_loop_back'b t ls0 ls1 i ret (** [loops::list_nth_shared_loop_pair]: loop 0: forward function *) -let rec list_nth_shared_loop_pair_loop_fwd +let rec list_nth_shared_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_shared_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) - else - let* i0 = u32_sub i 1 in - list_nth_shared_loop_pair_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_shared_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_loop_pair]: forward function *) -let list_nth_shared_loop_pair_fwd +let list_nth_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_loop_pair_loop_fwd t ls0 ls1 i + list_nth_shared_loop_pair_loop t ls0 ls1 i (** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_mut_loop_pair_merge_loop_fwd +let rec list_nth_mut_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else - let* i0 = u32_sub i 1 in - list_nth_mut_loop_pair_merge_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair_merge]: forward function *) -let list_nth_mut_loop_pair_merge_fwd +let list_nth_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_loop_pair_merge_loop_fwd t ls0 ls1 i + list_nth_mut_loop_pair_merge_loop t ls0 ls1 i (** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 *) let rec list_nth_mut_loop_pair_merge_loop_back @@ -404,19 +414,19 @@ let rec list_nth_mut_loop_pair_merge_loop_back (decreases (list_nth_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then let (x, x2) = ret in Return (ListCons x tl0, ListCons x2 tl1) + then let (x, x2) = ret in Return (List_Cons x tl0, List_Cons x2 tl1) else let* i0 = u32_sub i 1 in let* (tl00, tl10) = list_nth_mut_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (ListCons x0 tl00, ListCons x1 tl10) - | ListNil -> Fail Failure + Return (List_Cons x0 tl00, List_Cons x1 tl10) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair_merge]: backward function 0 *) @@ -427,54 +437,54 @@ let list_nth_mut_loop_pair_merge_back list_nth_mut_loop_pair_merge_loop_back t ls0 ls1 i ret (** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_shared_loop_pair_merge_loop_fwd +let rec list_nth_shared_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_shared_loop_pair_merge_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_shared_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_loop_pair_merge]: forward function *) -let list_nth_shared_loop_pair_merge_fwd +let list_nth_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_loop_pair_merge_loop_fwd t ls0 ls1 i + list_nth_shared_loop_pair_merge_loop t ls0 ls1 i (** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function *) -let rec list_nth_mut_shared_loop_pair_loop_fwd +let rec list_nth_mut_shared_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_mut_shared_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_mut_shared_loop_pair_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_mut_shared_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_shared_loop_pair]: forward function *) -let list_nth_mut_shared_loop_pair_fwd +let list_nth_mut_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_shared_loop_pair_loop_fwd t ls0 ls1 i + list_nth_mut_shared_loop_pair_loop t ls0 ls1 i (** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 *) let rec list_nth_mut_shared_loop_pair_loop_back @@ -483,18 +493,18 @@ let rec list_nth_mut_shared_loop_pair_loop_back (decreases (list_nth_mut_shared_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else let* i0 = u32_sub i 1 in let* tl00 = list_nth_mut_shared_loop_pair_loop_back t tl0 tl1 i0 ret in - Return (ListCons x0 tl00) - | ListNil -> Fail Failure + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_shared_loop_pair]: backward function 0 *) @@ -505,29 +515,29 @@ let list_nth_mut_shared_loop_pair_back list_nth_mut_shared_loop_pair_loop_back t ls0 ls1 i ret (** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_mut_shared_loop_pair_merge_loop_fwd +let rec list_nth_mut_shared_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_mut_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_mut_shared_loop_pair_merge_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_mut_shared_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_shared_loop_pair_merge]: forward function *) -let list_nth_mut_shared_loop_pair_merge_fwd +let list_nth_mut_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_shared_loop_pair_merge_loop_fwd t ls0 ls1 i + list_nth_mut_shared_loop_pair_merge_loop t ls0 ls1 i (** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 *) let rec list_nth_mut_shared_loop_pair_merge_loop_back @@ -536,19 +546,19 @@ let rec list_nth_mut_shared_loop_pair_merge_loop_back (decreases (list_nth_mut_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else let* i0 = u32_sub i 1 in let* tl00 = list_nth_mut_shared_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (ListCons x0 tl00) - | ListNil -> Fail Failure + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 *) @@ -559,29 +569,29 @@ let list_nth_mut_shared_loop_pair_merge_back list_nth_mut_shared_loop_pair_merge_loop_back t ls0 ls1 i ret (** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function *) -let rec list_nth_shared_mut_loop_pair_loop_fwd +let rec list_nth_shared_mut_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_shared_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_shared_mut_loop_pair_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_shared_mut_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_mut_loop_pair]: forward function *) -let list_nth_shared_mut_loop_pair_fwd +let list_nth_shared_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_mut_loop_pair_loop_fwd t ls0 ls1 i + list_nth_shared_mut_loop_pair_loop t ls0 ls1 i (** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 *) let rec list_nth_shared_mut_loop_pair_loop_back @@ -590,18 +600,18 @@ let rec list_nth_shared_mut_loop_pair_loop_back (decreases (list_nth_shared_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else let* i0 = u32_sub i 1 in let* tl10 = list_nth_shared_mut_loop_pair_loop_back t tl0 tl1 i0 ret in - Return (ListCons x1 tl10) - | ListNil -> Fail Failure + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_mut_loop_pair]: backward function 1 *) @@ -612,29 +622,29 @@ let list_nth_shared_mut_loop_pair_back list_nth_shared_mut_loop_pair_loop_back t ls0 ls1 i ret (** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_shared_mut_loop_pair_merge_loop_fwd +let rec list_nth_shared_mut_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_shared_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_shared_mut_loop_pair_merge_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_shared_mut_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_mut_loop_pair_merge]: forward function *) -let list_nth_shared_mut_loop_pair_merge_fwd +let list_nth_shared_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_mut_loop_pair_merge_loop_fwd t ls0 ls1 i + list_nth_shared_mut_loop_pair_merge_loop t ls0 ls1 i (** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 *) let rec list_nth_shared_mut_loop_pair_merge_loop_back @@ -643,19 +653,19 @@ let rec list_nth_shared_mut_loop_pair_merge_loop_back (decreases (list_nth_shared_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else let* i0 = u32_sub i 1 in let* tl10 = list_nth_shared_mut_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (ListCons x1 tl10) - | ListNil -> Fail Failure + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 *) diff --git a/tests/fstar/misc/Loops.Types.fst b/tests/fstar/misc/Loops.Types.fst index 2e032fe7..c622c548 100644 --- a/tests/fstar/misc/Loops.Types.fst +++ b/tests/fstar/misc/Loops.Types.fst @@ -7,6 +7,6 @@ open Primitives (** [loops::List] *) type list_t (t : Type0) = -| ListCons : t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t diff --git a/tests/fstar/misc/NoNestedBorrows.fst b/tests/fstar/misc/NoNestedBorrows.fst index 2cdd6e21..e97927aa 100644 --- a/tests/fstar/misc/NoNestedBorrows.fst +++ b/tests/fstar/misc/NoNestedBorrows.fst @@ -6,95 +6,107 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [no_nested_borrows::Pair] *) -type pair_t (t1 t2 : Type0) = { pair_x : t1; pair_y : t2; } +type pair_t (t1 t2 : Type0) = { x : t1; y : t2; } (** [no_nested_borrows::List] *) type list_t (t : Type0) = -| ListCons : t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t (** [no_nested_borrows::One] *) -type one_t (t1 : Type0) = | OneOne : t1 -> one_t t1 +type one_t (t1 : Type0) = | One_One : t1 -> one_t t1 (** [no_nested_borrows::EmptyEnum] *) -type empty_enum_t = | EmptyEnumEmpty : empty_enum_t +type emptyEnum_t = | EmptyEnum_Empty : emptyEnum_t (** [no_nested_borrows::Enum] *) -type enum_t = | EnumVariant1 : enum_t | EnumVariant2 : enum_t +type enum_t = | Enum_Variant1 : enum_t | Enum_Variant2 : enum_t (** [no_nested_borrows::EmptyStruct] *) -type empty_struct_t = unit +type emptyStruct_t = unit (** [no_nested_borrows::Sum] *) type sum_t (t1 t2 : Type0) = -| SumLeft : t1 -> sum_t t1 t2 -| SumRight : t2 -> sum_t t1 t2 +| Sum_Left : t1 -> sum_t t1 t2 +| Sum_Right : t2 -> sum_t t1 t2 (** [no_nested_borrows::neg_test]: forward function *) -let neg_test_fwd (x : i32) : result i32 = +let neg_test (x : i32) : result i32 = i32_neg x (** [no_nested_borrows::add_test]: forward function *) -let add_test_fwd (x : u32) (y : u32) : result u32 = +let add_test (x : u32) (y : u32) : result u32 = u32_add x y (** [no_nested_borrows::subs_test]: forward function *) -let subs_test_fwd (x : u32) (y : u32) : result u32 = +let subs_test (x : u32) (y : u32) : result u32 = u32_sub x y (** [no_nested_borrows::div_test]: forward function *) -let div_test_fwd (x : u32) (y : u32) : result u32 = +let div_test (x : u32) (y : u32) : result u32 = u32_div x y (** [no_nested_borrows::div_test1]: forward function *) -let div_test1_fwd (x : u32) : result u32 = +let div_test1 (x : u32) : result u32 = u32_div x 2 (** [no_nested_borrows::rem_test]: forward function *) -let rem_test_fwd (x : u32) (y : u32) : result u32 = +let rem_test (x : u32) (y : u32) : result u32 = u32_rem x y +(** [no_nested_borrows::mul_test]: forward function *) +let mul_test (x : u32) (y : u32) : result u32 = + u32_mul x y + +(** [no_nested_borrows::CONST0] *) +let const0_body : result usize = usize_add 1 1 +let const0_c : usize = eval_global const0_body + +(** [no_nested_borrows::CONST1] *) +let const1_body : result usize = usize_mul 2 2 +let const1_c : usize = eval_global const1_body + (** [no_nested_borrows::cast_test]: forward function *) -let cast_test_fwd (x : u32) : result i32 = +let cast_test (x : u32) : result i32 = scalar_cast U32 I32 x (** [no_nested_borrows::test2]: forward function *) -let test2_fwd : result unit = +let test2 : result unit = let* _ = u32_add 23 44 in Return () (** Unit test for [no_nested_borrows::test2] *) -let _ = assert_norm (test2_fwd = Return ()) +let _ = assert_norm (test2 = Return ()) (** [no_nested_borrows::get_max]: forward function *) -let get_max_fwd (x : u32) (y : u32) : result u32 = +let get_max (x : u32) (y : u32) : result u32 = if x >= y then Return x else Return y (** [no_nested_borrows::test3]: forward function *) -let test3_fwd : result unit = - let* x = get_max_fwd 4 3 in - let* y = get_max_fwd 10 11 in +let test3 : result unit = + let* x = get_max 4 3 in + let* y = get_max 10 11 in let* z = u32_add x y in if not (z = 15) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test3] *) -let _ = assert_norm (test3_fwd = Return ()) +let _ = assert_norm (test3 = Return ()) (** [no_nested_borrows::test_neg1]: forward function *) -let test_neg1_fwd : result unit = +let test_neg1 : result unit = let* y = i32_neg 3 in if not (y = -3) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_neg1] *) -let _ = assert_norm (test_neg1_fwd = Return ()) +let _ = assert_norm (test_neg1 = Return ()) (** [no_nested_borrows::refs_test1]: forward function *) -let refs_test1_fwd : result unit = +let refs_test1 : result unit = if not (1 = 1) then Fail Failure else Return () (** Unit test for [no_nested_borrows::refs_test1] *) -let _ = assert_norm (refs_test1_fwd = Return ()) +let _ = assert_norm (refs_test1 = Return ()) (** [no_nested_borrows::refs_test2]: forward function *) -let refs_test2_fwd : result unit = +let refs_test2 : result unit = if not (2 = 2) then Fail Failure else @@ -106,76 +118,76 @@ let refs_test2_fwd : result unit = else if not (2 = 2) then Fail Failure else Return () (** Unit test for [no_nested_borrows::refs_test2] *) -let _ = assert_norm (refs_test2_fwd = Return ()) +let _ = assert_norm (refs_test2 = Return ()) (** [no_nested_borrows::test_list1]: forward function *) -let test_list1_fwd : result unit = +let test_list1 : result unit = Return () (** Unit test for [no_nested_borrows::test_list1] *) -let _ = assert_norm (test_list1_fwd = Return ()) +let _ = assert_norm (test_list1 = Return ()) (** [no_nested_borrows::test_box1]: forward function *) -let test_box1_fwd : result unit = +let test_box1 : result unit = let b = 1 in let x = b in if not (x = 1) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_box1] *) -let _ = assert_norm (test_box1_fwd = Return ()) +let _ = assert_norm (test_box1 = Return ()) (** [no_nested_borrows::copy_int]: forward function *) -let copy_int_fwd (x : i32) : result i32 = +let copy_int (x : i32) : result i32 = Return x (** [no_nested_borrows::test_unreachable]: forward function *) -let test_unreachable_fwd (b : bool) : result unit = +let test_unreachable (b : bool) : result unit = if b then Fail Failure else Return () (** [no_nested_borrows::test_panic]: forward function *) -let test_panic_fwd (b : bool) : result unit = +let test_panic (b : bool) : result unit = if b then Fail Failure else Return () (** [no_nested_borrows::test_copy_int]: forward function *) -let test_copy_int_fwd : result unit = - let* y = copy_int_fwd 0 in if not (0 = y) then Fail Failure else Return () +let test_copy_int : result unit = + let* y = copy_int 0 in if not (0 = y) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_copy_int] *) -let _ = assert_norm (test_copy_int_fwd = Return ()) +let _ = assert_norm (test_copy_int = Return ()) (** [no_nested_borrows::is_cons]: forward function *) -let is_cons_fwd (t : Type0) (l : list_t t) : result bool = +let is_cons (t : Type0) (l : list_t t) : result bool = begin match l with - | ListCons x l0 -> Return true - | ListNil -> Return false + | List_Cons x l0 -> Return true + | List_Nil -> Return false end (** [no_nested_borrows::test_is_cons]: forward function *) -let test_is_cons_fwd : result unit = - let l = ListNil in - let* b = is_cons_fwd i32 (ListCons 0 l) in +let test_is_cons : result unit = + let l = List_Nil in + let* b = is_cons i32 (List_Cons 0 l) in if not b then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_is_cons] *) -let _ = assert_norm (test_is_cons_fwd = Return ()) +let _ = assert_norm (test_is_cons = Return ()) (** [no_nested_borrows::split_list]: forward function *) -let split_list_fwd (t : Type0) (l : list_t t) : result (t & (list_t t)) = +let split_list (t : Type0) (l : list_t t) : result (t & (list_t t)) = begin match l with - | ListCons hd tl -> Return (hd, tl) - | ListNil -> Fail Failure + | List_Cons hd tl -> Return (hd, tl) + | List_Nil -> Fail Failure end (** [no_nested_borrows::test_split_list]: forward function *) -let test_split_list_fwd : result unit = - let l = ListNil in - let* p = split_list_fwd i32 (ListCons 0 l) in +let test_split_list : result unit = + let l = List_Nil in + let* p = split_list i32 (List_Cons 0 l) in let (hd, _) = p in if not (hd = 0) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_split_list] *) -let _ = assert_norm (test_split_list_fwd = Return ()) +let _ = assert_norm (test_split_list = Return ()) (** [no_nested_borrows::choose]: forward function *) -let choose_fwd (t : Type0) (b : bool) (x : t) (y : t) : result t = +let choose (t : Type0) (b : bool) (x : t) (y : t) : result t = if b then Return x else Return y (** [no_nested_borrows::choose]: backward function 0 *) @@ -184,8 +196,8 @@ let choose_back if b then Return (ret, y) else Return (x, ret) (** [no_nested_borrows::choose_test]: forward function *) -let choose_test_fwd : result unit = - let* z = choose_fwd i32 true 0 0 in +let choose_test : result unit = + let* z = choose i32 true 0 0 in let* z0 = i32_add z 1 in if not (z0 = 1) then Fail Failure @@ -196,115 +208,112 @@ let choose_test_fwd : result unit = else if not (y = 0) then Fail Failure else Return () (** Unit test for [no_nested_borrows::choose_test] *) -let _ = assert_norm (choose_test_fwd = Return ()) +let _ = assert_norm (choose_test = Return ()) (** [no_nested_borrows::test_char]: forward function *) -let test_char_fwd : result char = +let test_char : result char = Return 'a' (** [no_nested_borrows::Tree] *) type tree_t (t : Type0) = -| TreeLeaf : t -> tree_t t -| TreeNode : t -> node_elem_t t -> tree_t t -> tree_t t +| Tree_Leaf : t -> tree_t t +| Tree_Node : t -> nodeElem_t t -> tree_t t -> tree_t t (** [no_nested_borrows::NodeElem] *) -and node_elem_t (t : Type0) = -| NodeElemCons : tree_t t -> node_elem_t t -> node_elem_t t -| NodeElemNil : node_elem_t t +and nodeElem_t (t : Type0) = +| NodeElem_Cons : tree_t t -> nodeElem_t t -> nodeElem_t t +| NodeElem_Nil : nodeElem_t t (** [no_nested_borrows::list_length]: forward function *) -let rec list_length_fwd (t : Type0) (l : list_t t) : result u32 = +let rec list_length (t : Type0) (l : list_t t) : result u32 = begin match l with - | ListCons x l1 -> let* i = list_length_fwd t l1 in u32_add 1 i - | ListNil -> Return 0 + | List_Cons x l1 -> let* i = list_length t l1 in u32_add 1 i + | List_Nil -> Return 0 end (** [no_nested_borrows::list_nth_shared]: forward function *) -let rec list_nth_shared_fwd (t : Type0) (l : list_t t) (i : u32) : result t = +let rec list_nth_shared (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_shared_fwd t tl i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_shared t tl i0 + | List_Nil -> Fail Failure end (** [no_nested_borrows::list_nth_mut]: forward function *) -let rec list_nth_mut_fwd (t : Type0) (l : list_t t) (i : u32) : result t = +let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with - | ListCons x tl -> - if i = 0 - then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_fwd t tl i0 - | ListNil -> Fail Failure + | List_Cons x tl -> + if i = 0 then Return x else let* i0 = u32_sub i 1 in list_nth_mut t tl i0 + | List_Nil -> Fail Failure end (** [no_nested_borrows::list_nth_mut]: backward function 0 *) let rec list_nth_mut_back (t : Type0) (l : list_t t) (i : u32) (ret : t) : result (list_t t) = begin match l with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else let* i0 = u32_sub i 1 in let* tl0 = list_nth_mut_back t tl i0 ret in - Return (ListCons x tl0) - | ListNil -> Fail Failure + Return (List_Cons x tl0) + | List_Nil -> Fail Failure end (** [no_nested_borrows::list_rev_aux]: forward function *) -let rec list_rev_aux_fwd +let rec list_rev_aux (t : Type0) (li : list_t t) (lo : list_t t) : result (list_t t) = begin match li with - | ListCons hd tl -> list_rev_aux_fwd t tl (ListCons hd lo) - | ListNil -> Return lo + | List_Cons hd tl -> list_rev_aux t tl (List_Cons hd lo) + | List_Nil -> Return lo end (** [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let list_rev_fwd_back (t : Type0) (l : list_t t) : result (list_t t) = - let li = mem_replace_fwd (list_t t) l ListNil in - list_rev_aux_fwd t li ListNil +let list_rev (t : Type0) (l : list_t t) : result (list_t t) = + let li = core_mem_replace (list_t t) l List_Nil in list_rev_aux t li List_Nil (** [no_nested_borrows::test_list_functions]: forward function *) -let test_list_functions_fwd : result unit = - let l = ListNil in - let l0 = ListCons 2 l in - let l1 = ListCons 1 l0 in - let* i = list_length_fwd i32 (ListCons 0 l1) in +let test_list_functions : result unit = + let l = List_Nil in + let l0 = List_Cons 2 l in + let l1 = List_Cons 1 l0 in + let* i = list_length i32 (List_Cons 0 l1) in if not (i = 3) then Fail Failure else - let* i0 = list_nth_shared_fwd i32 (ListCons 0 l1) 0 in + let* i0 = list_nth_shared i32 (List_Cons 0 l1) 0 in if not (i0 = 0) then Fail Failure else - let* i1 = list_nth_shared_fwd i32 (ListCons 0 l1) 1 in + let* i1 = list_nth_shared i32 (List_Cons 0 l1) 1 in if not (i1 = 1) then Fail Failure else - let* i2 = list_nth_shared_fwd i32 (ListCons 0 l1) 2 in + let* i2 = list_nth_shared i32 (List_Cons 0 l1) 2 in if not (i2 = 2) then Fail Failure else - let* ls = list_nth_mut_back i32 (ListCons 0 l1) 1 3 in - let* i3 = list_nth_shared_fwd i32 ls 0 in + let* ls = list_nth_mut_back i32 (List_Cons 0 l1) 1 3 in + let* i3 = list_nth_shared i32 ls 0 in if not (i3 = 0) then Fail Failure else - let* i4 = list_nth_shared_fwd i32 ls 1 in + let* i4 = list_nth_shared i32 ls 1 in if not (i4 = 3) then Fail Failure else - let* i5 = list_nth_shared_fwd i32 ls 2 in + let* i5 = list_nth_shared i32 ls 2 in if not (i5 = 2) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_list_functions] *) -let _ = assert_norm (test_list_functions_fwd = Return ()) +let _ = assert_norm (test_list_functions = Return ()) (** [no_nested_borrows::id_mut_pair1]: forward function *) -let id_mut_pair1_fwd (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = +let id_mut_pair1 (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = Return (x, y) (** [no_nested_borrows::id_mut_pair1]: backward function 0 *) @@ -313,7 +322,7 @@ let id_mut_pair1_back let (x0, x1) = ret in Return (x0, x1) (** [no_nested_borrows::id_mut_pair2]: forward function *) -let id_mut_pair2_fwd (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = +let id_mut_pair2 (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = let (x, x0) = p in Return (x, x0) (** [no_nested_borrows::id_mut_pair2]: backward function 0 *) @@ -322,7 +331,7 @@ let id_mut_pair2_back let (x, x0) = ret in Return (x, x0) (** [no_nested_borrows::id_mut_pair3]: forward function *) -let id_mut_pair3_fwd (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = +let id_mut_pair3 (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = Return (x, y) (** [no_nested_borrows::id_mut_pair3]: backward function 0 *) @@ -336,7 +345,7 @@ let id_mut_pair3_back'b Return ret (** [no_nested_borrows::id_mut_pair4]: forward function *) -let id_mut_pair4_fwd (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = +let id_mut_pair4 (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = let (x, x0) = p in Return (x, x0) (** [no_nested_borrows::id_mut_pair4]: backward function 0 *) @@ -350,81 +359,76 @@ let id_mut_pair4_back'b Return ret (** [no_nested_borrows::StructWithTuple] *) -type struct_with_tuple_t (t1 t2 : Type0) = { struct_with_tuple_p : (t1 & t2); } +type structWithTuple_t (t1 t2 : Type0) = { p : (t1 & t2); } (** [no_nested_borrows::new_tuple1]: forward function *) -let new_tuple1_fwd : result (struct_with_tuple_t u32 u32) = - Return { struct_with_tuple_p = (1, 2) } +let new_tuple1 : result (structWithTuple_t u32 u32) = + Return { p = (1, 2) } (** [no_nested_borrows::new_tuple2]: forward function *) -let new_tuple2_fwd : result (struct_with_tuple_t i16 i16) = - Return { struct_with_tuple_p = (1, 2) } +let new_tuple2 : result (structWithTuple_t i16 i16) = + Return { p = (1, 2) } (** [no_nested_borrows::new_tuple3]: forward function *) -let new_tuple3_fwd : result (struct_with_tuple_t u64 i64) = - Return { struct_with_tuple_p = (1, 2) } +let new_tuple3 : result (structWithTuple_t u64 i64) = + Return { p = (1, 2) } (** [no_nested_borrows::StructWithPair] *) -type struct_with_pair_t (t1 t2 : Type0) = -{ - struct_with_pair_p : pair_t t1 t2; -} +type structWithPair_t (t1 t2 : Type0) = { p : pair_t t1 t2; } (** [no_nested_borrows::new_pair1]: forward function *) -let new_pair1_fwd : result (struct_with_pair_t u32 u32) = - Return { struct_with_pair_p = { pair_x = 1; pair_y = 2 } } +let new_pair1 : result (structWithPair_t u32 u32) = + Return { p = { x = 1; y = 2 } } (** [no_nested_borrows::test_constants]: forward function *) -let test_constants_fwd : result unit = - let* swt = new_tuple1_fwd in - let (i, _) = swt.struct_with_tuple_p in +let test_constants : result unit = + let* swt = new_tuple1 in + let (i, _) = swt.p in if not (i = 1) then Fail Failure else - let* swt0 = new_tuple2_fwd in - let (i0, _) = swt0.struct_with_tuple_p in + let* swt0 = new_tuple2 in + let (i0, _) = swt0.p in if not (i0 = 1) then Fail Failure else - let* swt1 = new_tuple3_fwd in - let (i1, _) = swt1.struct_with_tuple_p in + let* swt1 = new_tuple3 in + let (i1, _) = swt1.p in if not (i1 = 1) then Fail Failure else - let* swp = new_pair1_fwd in - if not (swp.struct_with_pair_p.pair_x = 1) - then Fail Failure - else Return () + let* swp = new_pair1 in + if not (swp.p.x = 1) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_constants] *) -let _ = assert_norm (test_constants_fwd = Return ()) +let _ = assert_norm (test_constants = Return ()) (** [no_nested_borrows::test_weird_borrows1]: forward function *) -let test_weird_borrows1_fwd : result unit = +let test_weird_borrows1 : result unit = Return () (** Unit test for [no_nested_borrows::test_weird_borrows1] *) -let _ = assert_norm (test_weird_borrows1_fwd = Return ()) +let _ = assert_norm (test_weird_borrows1 = Return ()) (** [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let test_mem_replace_fwd_back (px : u32) : result u32 = - let y = mem_replace_fwd u32 px 1 in +let test_mem_replace (px : u32) : result u32 = + let y = core_mem_replace u32 px 1 in if not (y = 0) then Fail Failure else Return 2 (** [no_nested_borrows::test_shared_borrow_bool1]: forward function *) -let test_shared_borrow_bool1_fwd (b : bool) : result u32 = +let test_shared_borrow_bool1 (b : bool) : result u32 = if b then Return 0 else Return 1 (** [no_nested_borrows::test_shared_borrow_bool2]: forward function *) -let test_shared_borrow_bool2_fwd : result u32 = +let test_shared_borrow_bool2 : result u32 = Return 0 (** [no_nested_borrows::test_shared_borrow_enum1]: forward function *) -let test_shared_borrow_enum1_fwd (l : list_t u32) : result u32 = - begin match l with | ListCons i l0 -> Return 1 | ListNil -> Return 0 end +let test_shared_borrow_enum1 (l : list_t u32) : result u32 = + begin match l with | List_Cons i l0 -> Return 1 | List_Nil -> Return 0 end (** [no_nested_borrows::test_shared_borrow_enum2]: forward function *) -let test_shared_borrow_enum2_fwd : result u32 = +let test_shared_borrow_enum2 : result u32 = Return 0 diff --git a/tests/fstar/misc/Paper.fst b/tests/fstar/misc/Paper.fst index e2d692c2..bfb710dc 100644 --- a/tests/fstar/misc/Paper.fst +++ b/tests/fstar/misc/Paper.fst @@ -7,19 +7,18 @@ open Primitives (** [paper::ref_incr]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let ref_incr_fwd_back (x : i32) : result i32 = +let ref_incr (x : i32) : result i32 = i32_add x 1 (** [paper::test_incr]: forward function *) -let test_incr_fwd : result unit = - let* x = ref_incr_fwd_back 0 in - if not (x = 1) then Fail Failure else Return () +let test_incr : result unit = + let* x = ref_incr 0 in if not (x = 1) then Fail Failure else Return () (** Unit test for [paper::test_incr] *) -let _ = assert_norm (test_incr_fwd = Return ()) +let _ = assert_norm (test_incr = Return ()) (** [paper::choose]: forward function *) -let choose_fwd (t : Type0) (b : bool) (x : t) (y : t) : result t = +let choose (t : Type0) (b : bool) (x : t) (y : t) : result t = if b then Return x else Return y (** [paper::choose]: backward function 0 *) @@ -28,8 +27,8 @@ let choose_back if b then Return (ret, y) else Return (x, ret) (** [paper::test_choose]: forward function *) -let test_choose_fwd : result unit = - let* z = choose_fwd i32 true 0 0 in +let test_choose : result unit = + let* z = choose i32 true 0 0 in let* z0 = i32_add z 1 in if not (z0 = 1) then Fail Failure @@ -40,62 +39,60 @@ let test_choose_fwd : result unit = else if not (y = 0) then Fail Failure else Return () (** Unit test for [paper::test_choose] *) -let _ = assert_norm (test_choose_fwd = Return ()) +let _ = assert_norm (test_choose = Return ()) (** [paper::List] *) type list_t (t : Type0) = -| ListCons : t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t (** [paper::list_nth_mut]: forward function *) -let rec list_nth_mut_fwd (t : Type0) (l : list_t t) (i : u32) : result t = +let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with - | ListCons x tl -> - if i = 0 - then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_fwd t tl i0 - | ListNil -> Fail Failure + | List_Cons x tl -> + if i = 0 then Return x else let* i0 = u32_sub i 1 in list_nth_mut t tl i0 + | List_Nil -> Fail Failure end (** [paper::list_nth_mut]: backward function 0 *) let rec list_nth_mut_back (t : Type0) (l : list_t t) (i : u32) (ret : t) : result (list_t t) = begin match l with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else let* i0 = u32_sub i 1 in let* tl0 = list_nth_mut_back t tl i0 ret in - Return (ListCons x tl0) - | ListNil -> Fail Failure + Return (List_Cons x tl0) + | List_Nil -> Fail Failure end (** [paper::sum]: forward function *) -let rec sum_fwd (l : list_t i32) : result i32 = +let rec sum (l : list_t i32) : result i32 = begin match l with - | ListCons x tl -> let* i = sum_fwd tl in i32_add x i - | ListNil -> Return 0 + | List_Cons x tl -> let* i = sum tl in i32_add x i + | List_Nil -> Return 0 end (** [paper::test_nth]: forward function *) -let test_nth_fwd : result unit = - let l = ListNil in - let l0 = ListCons 3 l in - let l1 = ListCons 2 l0 in - let* x = list_nth_mut_fwd i32 (ListCons 1 l1) 2 in +let test_nth : result unit = + let l = List_Nil in + let l0 = List_Cons 3 l in + let l1 = List_Cons 2 l0 in + let* x = list_nth_mut i32 (List_Cons 1 l1) 2 in let* x0 = i32_add x 1 in - let* l2 = list_nth_mut_back i32 (ListCons 1 l1) 2 x0 in - let* i = sum_fwd l2 in + let* l2 = list_nth_mut_back i32 (List_Cons 1 l1) 2 x0 in + let* i = sum l2 in if not (i = 7) then Fail Failure else Return () (** Unit test for [paper::test_nth] *) -let _ = assert_norm (test_nth_fwd = Return ()) +let _ = assert_norm (test_nth = Return ()) (** [paper::call_choose]: forward function *) -let call_choose_fwd (p : (u32 & u32)) : result u32 = +let call_choose (p : (u32 & u32)) : result u32 = let (px, py) = p in - let* pz = choose_fwd u32 true px py in + let* pz = choose u32 true px py in let* pz0 = u32_add pz 1 in let* (px0, _) = choose_back u32 true px py pz0 in Return px0 diff --git a/tests/fstar/misc/PoloniusList.fst b/tests/fstar/misc/PoloniusList.fst index 79c86606..428c4210 100644 --- a/tests/fstar/misc/PoloniusList.fst +++ b/tests/fstar/misc/PoloniusList.fst @@ -7,25 +7,25 @@ open Primitives (** [polonius_list::List] *) type list_t (t : Type0) = -| ListCons : t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t (** [polonius_list::get_list_at_x]: forward function *) -let rec get_list_at_x_fwd (ls : list_t u32) (x : u32) : result (list_t u32) = +let rec get_list_at_x (ls : list_t u32) (x : u32) : result (list_t u32) = begin match ls with - | ListCons hd tl -> - if hd = x then Return (ListCons hd tl) else get_list_at_x_fwd tl x - | ListNil -> Return ListNil + | List_Cons hd tl -> + if hd = x then Return (List_Cons hd tl) else get_list_at_x tl x + | List_Nil -> Return List_Nil end (** [polonius_list::get_list_at_x]: backward function 0 *) let rec get_list_at_x_back (ls : list_t u32) (x : u32) (ret : list_t u32) : result (list_t u32) = begin match ls with - | ListCons hd tl -> + | List_Cons hd tl -> if hd = x then Return ret - else let* tl0 = get_list_at_x_back tl x ret in Return (ListCons hd tl0) - | ListNil -> Return ret + else let* tl0 = get_list_at_x_back tl x ret in Return (List_Cons hd tl0) + | List_Nil -> Return ret end diff --git a/tests/fstar/misc/Primitives.fst b/tests/fstar/misc/Primitives.fst index 9db82069..3297803c 100644 --- a/tests/fstar/misc/Primitives.fst +++ b/tests/fstar/misc/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -169,17 +187,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize @@ -231,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -259,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -278,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -295,55 +389,54 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -358,18 +451,279 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/traits/Makefile b/tests/fstar/traits/Makefile new file mode 100644 index 00000000..fa7d1f36 --- /dev/null +++ b/tests/fstar/traits/Makefile @@ -0,0 +1,49 @@ +# This file was automatically generated - modify ../Makefile.template instead +INCLUDE_DIRS = . + +FSTAR_INCLUDES = $(addprefix --include ,$(INCLUDE_DIRS)) + +FSTAR_HINTS ?= --use_hints --use_hint_hashes --record_hints + +FSTAR_OPTIONS = $(FSTAR_HINTS) \ + --cache_checked_modules $(FSTAR_INCLUDES) --cmi \ + --warn_error '+241@247+285-274' \ + +FSTAR_EXE ?= fstar.exe +FSTAR_NO_FLAGS = $(FSTAR_EXE) --already_cached 'Prims FStar LowStar Steel' --odir obj --cache_dir obj + +FSTAR = $(FSTAR_NO_FLAGS) $(FSTAR_OPTIONS) + +# The F* roots are used to compute the dependency graph, and generate the .depend file +FSTAR_ROOTS ?= $(wildcard *.fst *.fsti) + +# Build all the files +all: $(addprefix obj/,$(addsuffix .checked,$(FSTAR_ROOTS))) + +# This is the right way to ensure the .depend file always gets re-built. +ifeq (,$(filter %-in,$(MAKECMDGOALS))) +ifndef NODEPEND +ifndef MAKE_RESTARTS +.depend: .FORCE + $(FSTAR_NO_FLAGS) --dep full $(notdir $(FSTAR_ROOTS)) > $@ + +.PHONY: .FORCE +.FORCE: +endif +endif + +include .depend +endif + +# For the interactive mode +%.fst-in %.fsti-in: + @echo $(FSTAR_OPTIONS) + +# Generete the .checked files in batch mode +%.checked: + $(FSTAR) $(FSTAR_OPTIONS) $< && \ + touch -c $@ + +.PHONY: clean +clean: + rm -f obj/* diff --git a/tests/fstar/traits/Primitives.fst b/tests/fstar/traits/Primitives.fst new file mode 100644 index 00000000..3297803c --- /dev/null +++ b/tests/fstar/traits/Primitives.fst @@ -0,0 +1,729 @@ +/// This file lists primitive and assumed functions and types +module Primitives +open FStar.Mul +open FStar.List.Tot + +#set-options "--z3rlimit 15 --fuel 0 --ifuel 1" + +(*** Utilities *) +val list_update (#a : Type0) (ls : list a) (i : nat{i < length ls}) (x : a) : + ls':list a{ + length ls' = length ls /\ + index ls' i == x + } +#push-options "--fuel 1" +let rec list_update #a ls i x = + match ls with + | x' :: ls -> if i = 0 then x :: ls else x' :: list_update ls (i-1) x +#pop-options + +(*** Result *) +type error : Type0 = +| Failure +| OutOfFuel + +type result (a : Type0) : Type0 = +| Return : v:a -> result a +| Fail : e:error -> result a + +// Monadic return operator +unfold let return (#a : Type0) (x : a) : result a = Return x + +// Monadic bind operator. +// Allows to use the notation: +// ``` +// let* x = y in +// ... +// ``` +unfold let (let*) (#a #b : Type0) (m: result a) + (f: (x:a) -> Pure (result b) (requires (m == Return x)) (ensures fun _ -> True)) : + result b = + match m with + | Return x -> f x + | Fail e -> Fail e + +// Monadic assert(...) +let massert (b:bool) : result unit = if b then Return () else Fail Failure + +// Normalize and unwrap a successful result (used for globals). +let eval_global (#a : Type0) (x : result a{Return? (normalize_term x)}) : a = Return?.v x + +(*** Misc *) +type char = FStar.Char.char +type string = string + +let is_zero (n: nat) : bool = n = 0 +let decrease (n: nat{n > 0}) : nat = n - 1 + +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } + +(*** Scalars *) +/// Rem.: most of the following code was partially generated + +let isize_min : int = -9223372036854775808 // TODO: should be opaque +let isize_max : int = 9223372036854775807 // TODO: should be opaque +let i8_min : int = -128 +let i8_max : int = 127 +let i16_min : int = -32768 +let i16_max : int = 32767 +let i32_min : int = -2147483648 +let i32_max : int = 2147483647 +let i64_min : int = -9223372036854775808 +let i64_max : int = 9223372036854775807 +let i128_min : int = -170141183460469231731687303715884105728 +let i128_max : int = 170141183460469231731687303715884105727 +let usize_min : int = 0 +let usize_max : int = 4294967295 // TODO: should be opaque +let u8_min : int = 0 +let u8_max : int = 255 +let u16_min : int = 0 +let u16_max : int = 65535 +let u32_min : int = 0 +let u32_max : int = 4294967295 +let u64_min : int = 0 +let u64_max : int = 18446744073709551615 +let u128_min : int = 0 +let u128_max : int = 340282366920938463463374607431768211455 + +type scalar_ty = +| Isize +| I8 +| I16 +| I32 +| I64 +| I128 +| Usize +| U8 +| U16 +| U32 +| U64 +| U128 + +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + +let scalar_min (ty : scalar_ty) : int = + match ty with + | Isize -> isize_min + | I8 -> i8_min + | I16 -> i16_min + | I32 -> i32_min + | I64 -> i64_min + | I128 -> i128_min + | Usize -> usize_min + | U8 -> u8_min + | U16 -> u16_min + | U32 -> u32_min + | U64 -> u64_min + | U128 -> u128_min + +let scalar_max (ty : scalar_ty) : int = + match ty with + | Isize -> isize_max + | I8 -> i8_max + | I16 -> i16_max + | I32 -> i32_max + | I64 -> i64_max + | I128 -> i128_max + | Usize -> usize_max + | U8 -> u8_max + | U16 -> u16_max + | U32 -> u32_max + | U64 -> u64_max + | U128 -> u128_max + +type scalar (ty : scalar_ty) : eqtype = x:int{scalar_min ty <= x && x <= scalar_max ty} + +let mk_scalar (ty : scalar_ty) (x : int) : result (scalar ty) = + if scalar_min ty <= x && scalar_max ty >= x then Return x else Fail Failure + +let scalar_neg (#ty : scalar_ty) (x : scalar ty) : result (scalar ty) = mk_scalar ty (-x) + +let scalar_div (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (x / y) else Fail Failure + +/// The remainder operation +let int_rem (x : int) (y : int{y <> 0}) : int = + if x >= 0 then (x % y) else -(x % y) + +(* Checking consistency with Rust *) +let _ = assert_norm(int_rem 1 2 = 1) +let _ = assert_norm(int_rem (-1) 2 = -1) +let _ = assert_norm(int_rem 1 (-2) = 1) +let _ = assert_norm(int_rem (-1) (-2) = -1) + +let scalar_rem (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (int_rem x y) else Fail Failure + +let scalar_add (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x + y) + +let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x - y) + +let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x * y) + +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + +(** Cast an integer from a [src_ty] to a [tgt_ty] *) +// TODO: check the semantics of casts in Rust +let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = + mk_scalar tgt_ty x + +/// The scalar types +type isize : eqtype = scalar Isize +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 +type usize : eqtype = scalar Usize +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max + +/// Negation +let isize_neg = scalar_neg #Isize +let i8_neg = scalar_neg #I8 +let i16_neg = scalar_neg #I16 +let i32_neg = scalar_neg #I32 +let i64_neg = scalar_neg #I64 +let i128_neg = scalar_neg #I128 + +/// Division +let isize_div = scalar_div #Isize +let i8_div = scalar_div #I8 +let i16_div = scalar_div #I16 +let i32_div = scalar_div #I32 +let i64_div = scalar_div #I64 +let i128_div = scalar_div #I128 +let usize_div = scalar_div #Usize +let u8_div = scalar_div #U8 +let u16_div = scalar_div #U16 +let u32_div = scalar_div #U32 +let u64_div = scalar_div #U64 +let u128_div = scalar_div #U128 + +/// Remainder +let isize_rem = scalar_rem #Isize +let i8_rem = scalar_rem #I8 +let i16_rem = scalar_rem #I16 +let i32_rem = scalar_rem #I32 +let i64_rem = scalar_rem #I64 +let i128_rem = scalar_rem #I128 +let usize_rem = scalar_rem #Usize +let u8_rem = scalar_rem #U8 +let u16_rem = scalar_rem #U16 +let u32_rem = scalar_rem #U32 +let u64_rem = scalar_rem #U64 +let u128_rem = scalar_rem #U128 + +/// Addition +let isize_add = scalar_add #Isize +let i8_add = scalar_add #I8 +let i16_add = scalar_add #I16 +let i32_add = scalar_add #I32 +let i64_add = scalar_add #I64 +let i128_add = scalar_add #I128 +let usize_add = scalar_add #Usize +let u8_add = scalar_add #U8 +let u16_add = scalar_add #U16 +let u32_add = scalar_add #U32 +let u64_add = scalar_add #U64 +let u128_add = scalar_add #U128 + +/// Subtraction +let isize_sub = scalar_sub #Isize +let i8_sub = scalar_sub #I8 +let i16_sub = scalar_sub #I16 +let i32_sub = scalar_sub #I32 +let i64_sub = scalar_sub #I64 +let i128_sub = scalar_sub #I128 +let usize_sub = scalar_sub #Usize +let u8_sub = scalar_sub #U8 +let u16_sub = scalar_sub #U16 +let u32_sub = scalar_sub #U32 +let u64_sub = scalar_sub #U64 +let u128_sub = scalar_sub #U128 + +/// Multiplication +let isize_mul = scalar_mul #Isize +let i8_mul = scalar_mul #I8 +let i16_mul = scalar_mul #I16 +let i32_mul = scalar_mul #I32 +let i64_mul = scalar_mul #I64 +let i128_mul = scalar_mul #I128 +let usize_mul = scalar_mul #Usize +let u8_mul = scalar_mul #U8 +let u16_mul = scalar_mul #U16 +let u32_mul = scalar_mul #U32 +let u64_mul = scalar_mul #U64 +let u128_mul = scalar_mul #U128 + +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { + start : a; + end_ : a; +} + +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + +(*** Array *) +type array (a : Type0) (n : usize) = s:list a{length s = n} + +// We tried putting the normalize_term condition as a refinement on the list +// but it didn't work. It works with the requires clause. +let mk_array (a : Type0) (n : usize) + (l : list a) : + Pure (array a n) + (requires (normalize_term(FStar.List.Tot.length l) = n)) + (ensures (fun _ -> True)) = + normalize_term_spec (FStar.List.Tot.length l); + l + +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = + if i < length x then Return (index x i) + else Fail Failure + +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = + if i < length x then Return (list_update x i nx) + else Fail Failure + +(*** Slice *) +type slice (a : Type0) = s:list a{length s <= usize_max} + +let slice_len (a : Type0) (s : slice a) : usize = length s + +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = + if i < length x then Return (index x i) + else Fail Failure + +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = + if i < length x then Return (list_update x i nx) + else Fail Failure + +(*** Subslices *) + +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = + if length s = n then Return s + else Fail Failure + +// TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = + admit() + +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = + admit() + +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = + admit() + +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = + admit() + +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = + admit() + +(*** Vector *) +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} + +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + +// The **forward** function shouldn't be used +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) + (requires True) + (ensures (fun res -> + match res with + | Fail e -> e == Failure + | Return v' -> length v' = length v + 1)) = + if length v < usize_max then begin + (**) assert_norm(length [x] == 1); + (**) append_length v [x]; + (**) assert(length (append v [x]) = length v + 1); + Return (append v [x]) + end + else Fail Failure + +// The **forward** function shouldn't be used +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = + if i < length v then Return () else Fail Failure +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} + +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst new file mode 100644 index 00000000..318efa2b --- /dev/null +++ b/tests/fstar/traits/Traits.fst @@ -0,0 +1,371 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [traits] *) +module Traits +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** Trait declaration: [traits::BoolTrait] *) +noeq type boolTrait_t (self : Type0) = { get_bool : self -> result bool; } + +(** [traits::Bool::{0}::get_bool]: forward function *) +let bool_get_bool (self : bool) : result bool = + Return self + +(** Trait implementation: [traits::Bool::{0}] *) +let bool_BoolTraitInst : boolTrait_t bool = { get_bool = bool_get_bool; } + +(** [traits::BoolTrait::ret_true]: forward function *) +let boolTrait_ret_true + (#self : Type0) (self_clause : boolTrait_t self) (self0 : self) : + result bool + = + Return true + +(** [traits::test_bool_trait_bool]: forward function *) +let test_bool_trait_bool (x : bool) : result bool = + let* b = bool_get_bool x in + if b then boolTrait_ret_true bool_BoolTraitInst x else Return false + +(** [traits::Option::{1}::get_bool]: forward function *) +let option_get_bool (t : Type0) (self : option t) : result bool = + begin match self with | None -> Return false | Some x -> Return true end + +(** Trait implementation: [traits::Option::{1}] *) +let option_BoolTraitInst (t : Type0) : boolTrait_t (option t) = { + get_bool = option_get_bool t; +} + +(** [traits::test_bool_trait_option]: forward function *) +let test_bool_trait_option (t : Type0) (x : option t) : result bool = + let* b = option_get_bool t x in + if b then boolTrait_ret_true (option_BoolTraitInst t) x else Return false + +(** [traits::test_bool_trait]: forward function *) +let test_bool_trait (t : Type0) (inst : boolTrait_t t) (x : t) : result bool = + inst.get_bool x + +(** Trait declaration: [traits::ToU64] *) +noeq type toU64_t (self : Type0) = { to_u64 : self -> result u64; } + +(** [traits::u64::{2}::to_u64]: forward function *) +let u64_to_u64 (self : u64) : result u64 = + Return self + +(** Trait implementation: [traits::u64::{2}] *) +let u64_ToU64Inst : toU64_t u64 = { to_u64 = u64_to_u64; } + +(** [traits::Tuple2::{3}::to_u64]: forward function *) +let tuple2_to_u64 + (a : Type0) (inst : toU64_t a) (self : (a & a)) : result u64 = + let (x, x0) = self in + let* i = inst.to_u64 x in + let* i0 = inst.to_u64 x0 in + u64_add i i0 + +(** Trait implementation: [traits::Tuple2::{3}] *) +let tuple2_ToU64Inst (a : Type0) (inst : toU64_t a) : toU64_t (a & a) = { + to_u64 = tuple2_to_u64 a inst; +} + +(** [traits::f]: forward function *) +let f (t : Type0) (inst : toU64_t t) (x : (t & t)) : result u64 = + tuple2_to_u64 t inst x + +(** [traits::g]: forward function *) +let g (t : Type0) (inst : toU64_t (t & t)) (x : (t & t)) : result u64 = + inst.to_u64 x + +(** [traits::h0]: forward function *) +let h0 (x : u64) : result u64 = + u64_to_u64 x + +(** [traits::Wrapper] *) +type wrapper_t (t : Type0) = { x : t; } + +(** [traits::Wrapper::{4}::to_u64]: forward function *) +let wrapper_to_u64 + (t : Type0) (inst : toU64_t t) (self : wrapper_t t) : result u64 = + inst.to_u64 self.x + +(** Trait implementation: [traits::Wrapper::{4}] *) +let wrapper_ToU64Inst (t : Type0) (inst : toU64_t t) : toU64_t (wrapper_t t) + = { + to_u64 = wrapper_to_u64 t inst; +} + +(** [traits::h1]: forward function *) +let h1 (x : wrapper_t u64) : result u64 = + wrapper_to_u64 u64 u64_ToU64Inst x + +(** [traits::h2]: forward function *) +let h2 (t : Type0) (inst : toU64_t t) (x : wrapper_t t) : result u64 = + wrapper_to_u64 t inst x + +(** Trait declaration: [traits::ToType] *) +noeq type toType_t (self t : Type0) = { to_type : self -> result t; } + +(** [traits::u64::{5}::to_type]: forward function *) +let u64_to_type (self : u64) : result bool = + Return (self > 0) + +(** Trait implementation: [traits::u64::{5}] *) +let u64_ToTypeInst : toType_t u64 bool = { to_type = u64_to_type; } + +(** Trait declaration: [traits::OfType] *) +noeq type ofType_t (self : Type0) = { + of_type : (t : Type0) -> (inst : toType_t t self) -> t -> result self; +} + +(** [traits::h3]: forward function *) +let h3 + (t1 t2 : Type0) (inst : ofType_t t1) (inst0 : toType_t t2 t1) (y : t2) : + result t1 + = + inst.of_type t2 inst0 y + +(** Trait declaration: [traits::OfTypeBis] *) +noeq type ofTypeBis_t (self t : Type0) = { + parent_clause_0 : toType_t t self; + of_type : t -> result self; +} + +(** [traits::h4]: forward function *) +let h4 + (t1 t2 : Type0) (inst : ofTypeBis_t t1 t2) (inst0 : toType_t t2 t1) + (y : t2) : + result t1 + = + inst.of_type y + +(** [traits::TestType] *) +type testType_t (t : Type0) = { _0 : t; } + +(** [traits::TestType::{6}::test::TestType1] *) +type testType_test_TestType1_t = { _0 : u64; } + +(** Trait declaration: [traits::TestType::{6}::test::TestTrait] *) +noeq type testType_test_TestTrait_t (self : Type0) = { + test : self -> result bool; +} + +(** [traits::TestType::{6}::test::TestType1::{0}::test]: forward function *) +let testType_test_TestType1_test + (self : testType_test_TestType1_t) : result bool = + Return (self._0 > 1) + +(** Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] *) +let testType_test_TestType1_TestType_test_TestTraitInst : + testType_test_TestTrait_t testType_test_TestType1_t = { + test = testType_test_TestType1_test; +} + +(** [traits::TestType::{6}::test]: forward function *) +let testType_test + (t : Type0) (inst : toU64_t t) (self : testType_t t) (x : t) : result bool = + let* x0 = inst.to_u64 x in + if x0 > 0 then testType_test_TestType1_test { _0 = 0 } else Return false + +(** [traits::BoolWrapper] *) +type boolWrapper_t = { _0 : bool; } + +(** [traits::BoolWrapper::{7}::to_type]: forward function *) +let boolWrapper_to_type + (t : Type0) (inst : toType_t bool t) (self : boolWrapper_t) : result t = + inst.to_type self._0 + +(** Trait implementation: [traits::BoolWrapper::{7}] *) +let boolWrapper_ToTypeInst (t : Type0) (inst : toType_t bool t) : toType_t + boolWrapper_t t = { + to_type = boolWrapper_to_type t inst; +} + +(** [traits::WithConstTy::LEN2] *) +let with_const_ty_len2_body : result usize = Return 32 +let with_const_ty_len2_c : usize = eval_global with_const_ty_len2_body + +(** Trait declaration: [traits::WithConstTy] *) +noeq type withConstTy_t (self : Type0) (len : usize) = { + cLEN1 : usize; + cLEN2 : usize; + tV : Type0; + tW : Type0; + tW_clause_0 : toU64_t tW; + f : tW -> array u8 len -> result tW; +} + +(** [traits::Bool::{8}::LEN1] *) +let bool_len1_body : result usize = Return 12 +let bool_len1_c : usize = eval_global bool_len1_body + +(** [traits::Bool::{8}::f]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let bool_f (i : u64) (a : array u8 32) : result u64 = + Return i + +(** Trait implementation: [traits::Bool::{8}] *) +let bool_WithConstTyInst : withConstTy_t bool 32 = { + cLEN1 = bool_len1_c; + cLEN2 = with_const_ty_len2_c; + tV = u8; + tW = u64; + tW_clause_0 = u64_ToU64Inst; + f = bool_f; +} + +(** [traits::use_with_const_ty1]: forward function *) +let use_with_const_ty1 + (h : Type0) (len : usize) (inst : withConstTy_t h len) : result usize = + let i = inst.cLEN1 in Return i + +(** [traits::use_with_const_ty2]: forward function *) +let use_with_const_ty2 + (h : Type0) (len : usize) (inst : withConstTy_t h len) (w : inst.tW) : + result unit + = + Return () + +(** [traits::use_with_const_ty3]: forward function *) +let use_with_const_ty3 + (h : Type0) (len : usize) (inst : withConstTy_t h len) (x : inst.tW) : + result u64 + = + inst.tW_clause_0.to_u64 x + +(** [traits::test_where1]: forward function *) +let test_where1 (t : Type0) (_x : t) : result unit = + Return () + +(** [traits::test_where2]: forward function *) +let test_where2 + (t : Type0) (inst : withConstTy_t t 32) (_x : u32) : result unit = + Return () + +(** [alloc::string::String] *) +assume type alloc_string_String_t : Type0 + +(** Trait declaration: [traits::ParentTrait0] *) +noeq type parentTrait0_t (self : Type0) = { + tW : Type0; + get_name : self -> result alloc_string_String_t; + get_w : self -> result tW; +} + +(** Trait declaration: [traits::ParentTrait1] *) +type parentTrait1_t (self : Type0) = unit + +(** Trait declaration: [traits::ChildTrait] *) +noeq type childTrait_t (self : Type0) = { + parent_clause_0 : parentTrait0_t self; + parent_clause_1 : parentTrait1_t self; +} + +(** [traits::test_child_trait1]: forward function *) +let test_child_trait1 + (t : Type0) (inst : childTrait_t t) (x : t) : result alloc_string_String_t = + inst.parent_clause_0.get_name x + +(** [traits::test_child_trait2]: forward function *) +let test_child_trait2 + (t : Type0) (inst : childTrait_t t) (x : t) : + result inst.parent_clause_0.tW + = + inst.parent_clause_0.get_w x + +(** [traits::order1]: forward function *) +let order1 + (t u : Type0) (inst : parentTrait0_t t) (inst0 : parentTrait0_t u) : + result unit + = + Return () + +(** Trait declaration: [traits::ChildTrait1] *) +noeq type childTrait1_t (self : Type0) = { + parent_clause_0 : parentTrait1_t self; +} + +(** Trait implementation: [traits::usize::{9}] *) +let usize_ParentTrait1Inst : parentTrait1_t usize = () + +(** Trait implementation: [traits::usize::{10}] *) +let usize_ChildTrait1Inst : childTrait1_t usize = { + parent_clause_0 = usize_ParentTrait1Inst; +} + +(** Trait declaration: [traits::Iterator] *) +noeq type iterator_t (self : Type0) = { tItem : Type0; } + +(** Trait declaration: [traits::IntoIterator] *) +noeq type intoIterator_t (self : Type0) = { + tItem : Type0; + tIntoIter : Type0; + tIntoIter_clause_0 : iterator_t tIntoIter; + into_iter : self -> result tIntoIter; +} + +(** Trait declaration: [traits::FromResidual] *) +type fromResidual_t (self t : Type0) = unit + +(** Trait declaration: [traits::Try] *) +noeq type try_t (self : Type0) = { + tResidual : Type0; + parent_clause_0 : fromResidual_t self tResidual; +} + +(** Trait declaration: [traits::WithTarget] *) +noeq type withTarget_t (self : Type0) = { tTarget : Type0; } + +(** Trait declaration: [traits::ParentTrait2] *) +noeq type parentTrait2_t (self : Type0) = { + tU : Type0; + tU_clause_0 : withTarget_t tU; +} + +(** Trait declaration: [traits::ChildTrait2] *) +noeq type childTrait2_t (self : Type0) = { + parent_clause_0 : parentTrait2_t self; + convert : parent_clause_0.tU -> result parent_clause_0.tU_clause_0.tTarget; +} + +(** Trait implementation: [traits::u32::{11}] *) +let u32_WithTargetInst : withTarget_t u32 = { tTarget = u32; } + +(** Trait implementation: [traits::u32::{12}] *) +let u32_ParentTrait2Inst : parentTrait2_t u32 = { + tU = u32; + tU_clause_0 = u32_WithTargetInst; +} + +(** [traits::u32::{13}::convert]: forward function *) +let u32_convert (x : u32) : result u32 = + Return x + +(** Trait implementation: [traits::u32::{13}] *) +let u32_ChildTrait2Inst : childTrait2_t u32 = { + parent_clause_0 = u32_ParentTrait2Inst; + convert = u32_convert; +} + +(** [traits::incr_u32]: forward function *) +let incr_u32 (x : u32) : result u32 = + u32_add x 1 + +(** Trait declaration: [traits::CFnOnce] *) +noeq type cFnOnce_t (self args : Type0) = { + tOutput : Type0; + call_once : self -> args -> result tOutput; +} + +(** Trait declaration: [traits::CFnMut] *) +noeq type cFnMut_t (self args : Type0) = { + parent_clause_0 : cFnOnce_t self args; + call_mut : self -> args -> result parent_clause_0.tOutput; + call_mut_back : self -> args -> parent_clause_0.tOutput -> result self; +} + +(** Trait declaration: [traits::CFn] *) +noeq type cFn_t (self args : Type0) = { + parent_clause_0 : cFnMut_t self args; + call_mut : self -> args -> result parent_clause_0.parent_clause_0.tOutput; +} + diff --git a/tests/hol4/betree/betreeMain_FunsScript.sml b/tests/hol4/betree/betreeMain_FunsScript.sml index 5e604f8c..bd16c16c 100644 --- a/tests/hol4/betree/betreeMain_FunsScript.sml +++ b/tests/hol4/betree/betreeMain_FunsScript.sml @@ -88,14 +88,6 @@ val betree_node_id_counter_fresh_id_back_def = Define ‘ od ’ -(** [core::num::u64::{9}::MAX] *) -Definition core_num_u64_max_body_def: - core_num_u64_max_body : u64 result = Return (int_to_u64 18446744073709551615) -End -Definition core_num_u64_max_c_def: - core_num_u64_max_c : u64 = get_return_value core_num_u64_max_body -End - val betree_upsert_update_fwd_def = Define ‘ (** [betree_main::betree::upsert_update]: forward function *) betree_upsert_update_fwd @@ -109,8 +101,8 @@ val betree_upsert_update_fwd_def = Define ‘ (case st of | BetreeUpsertFunStateAdd v => do - margin <- u64_sub core_num_u64_max_c prev0; - if u64_ge margin v then u64_add prev0 v else Return core_num_u64_max_c + margin <- u64_sub core_u64_max prev0; + if u64_ge margin v then u64_add prev0 v else Return core_u64_max od | BetreeUpsertFunStateSub v => if u64_ge prev0 v then u64_sub prev0 v else Return (int_to_u64 0))) diff --git a/tests/hol4/betree/betreeMain_FunsTheory.sig b/tests/hol4/betree/betreeMain_FunsTheory.sig index 6c249f70..c922ca9f 100644 --- a/tests/hol4/betree/betreeMain_FunsTheory.sig +++ b/tests/hol4/betree/betreeMain_FunsTheory.sig @@ -58,8 +58,6 @@ sig val betree_store_internal_node_fwd_def : thm val betree_store_leaf_node_fwd_def : thm val betree_upsert_update_fwd_def : thm - val core_num_u64_max_body_def : thm - val core_num_u64_max_c_def : thm val main_fwd_def : thm val betreeMain_Funs_grammars : type_grammar.grammar * term_grammar.grammar @@ -1215,22 +1213,14 @@ sig case st of BetreeUpsertFunStateAdd v => do - margin <- u64_sub core_num_u64_max_c prev0; + margin <- u64_sub core_u64_max prev0; if u64_ge margin v then u64_add prev0 v - else Return core_num_u64_max_c + else Return core_u64_max od | BetreeUpsertFunStateSub v' => if u64_ge prev0 v' then u64_sub prev0 v' else Return (int_to_u64 0) - [core_num_u64_max_body_def] Definition - - ⊢ core_num_u64_max_body = Return (int_to_u64 18446744073709551615) - - [core_num_u64_max_c_def] Definition - - ⊢ core_num_u64_max_c = get_return_value core_num_u64_max_body - [main_fwd_def] Definition ⊢ main_fwd = Return () diff --git a/tests/hol4/hashmap/hashmap_FunsScript.sml b/tests/hol4/hashmap/hashmap_FunsScript.sml index e3c3d2a5..682c5760 100644 --- a/tests/hol4/hashmap/hashmap_FunsScript.sml +++ b/tests/hol4/hashmap/hashmap_FunsScript.sml @@ -170,14 +170,6 @@ val hash_map_insert_no_resize_fwd_back_def = Define ‘ od ’ -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body_def: - core_num_u32_max_body : u32 result = Return (int_to_u32 4294967295) -End -Definition core_num_u32_max_c_def: - core_num_u32_max_c : u32 = get_return_value core_num_u32_max_body -End - val [hash_map_move_elements_from_list_loop_fwd_back_def] = DefineDiv ‘ (** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) @@ -241,7 +233,7 @@ val hash_map_try_resize_fwd_back_def = Define ‘ (there is a single backward function, and the forward function returns ()) *) hash_map_try_resize_fwd_back (self : 't hash_map_t) : 't hash_map_t result = do - max_usize <- mk_usize (u32_to_int core_num_u32_max_c); + max_usize <- mk_usize (u32_to_int core_u32_max); let capacity = vec_len self.hash_map_slots in do n1 <- usize_div max_usize (int_to_usize 2); diff --git a/tests/hol4/hashmap/hashmap_FunsTheory.sig b/tests/hol4/hashmap/hashmap_FunsTheory.sig index 50482547..bb3e192b 100644 --- a/tests/hol4/hashmap/hashmap_FunsTheory.sig +++ b/tests/hol4/hashmap/hashmap_FunsTheory.sig @@ -3,8 +3,6 @@ sig type thm = Thm.thm (* Definitions *) - val core_num_u32_max_body_def : thm - val core_num_u32_max_c_def : thm val hash_key_fwd_def : thm val hash_map_allocate_slots_fwd_def : thm val hash_map_allocate_slots_loop_fwd_def : thm @@ -48,14 +46,6 @@ sig (* [hashmap_Types] Parent theory of "hashmap_Funs" - [core_num_u32_max_body_def] Definition - - ⊢ core_num_u32_max_body = Return (int_to_u32 4294967295) - - [core_num_u32_max_c_def] Definition - - ⊢ core_num_u32_max_c = get_return_value core_num_u32_max_body - [hash_key_fwd_def] Definition ⊢ ∀k. hash_key_fwd k = Return k @@ -472,7 +462,7 @@ sig ⊢ ∀self. hash_map_try_resize_fwd_back self = do - max_usize <- mk_usize (u32_to_int core_num_u32_max_c); + max_usize <- mk_usize (u32_to_int core_u32_max); capacity <<- vec_len self.hash_map_slots; n1 <- usize_div max_usize (int_to_usize 2); (i,i0) <<- self.hash_map_max_load_factor; diff --git a/tests/hol4/hashmap/hashmap_PropertiesScript.sml b/tests/hol4/hashmap/hashmap_PropertiesScript.sml index 7259f2f5..8bc12fa5 100644 --- a/tests/hol4/hashmap/hashmap_PropertiesScript.sml +++ b/tests/hol4/hashmap/hashmap_PropertiesScript.sml @@ -1296,7 +1296,7 @@ Proof rw [hash_map_try_resize_fwd_back_def] >> (* “_ <-- mk_usize (u32_to_int core_num_u32_max_c)” *) assume_tac usize_u32_bounds >> - fs [core_num_u32_max_c_def, core_num_u32_max_body_def, get_return_value_def, u32_max_def] >> + fs [core_u32_max_def, u32_max_def] >> massage >> fs [mk_usize_def, u32_max_def] >> (* / 2 *) progress >> diff --git a/tests/hol4/hashmap_on_disk/hashmapMain_FunsScript.sml b/tests/hol4/hashmap_on_disk/hashmapMain_FunsScript.sml index b21c4f58..c1e30aa6 100644 --- a/tests/hol4/hashmap_on_disk/hashmapMain_FunsScript.sml +++ b/tests/hol4/hashmap_on_disk/hashmapMain_FunsScript.sml @@ -193,14 +193,6 @@ val hashmap_hash_map_insert_no_resize_fwd_back_def = Define ‘ od ’ -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body_def: - core_num_u32_max_body : u32 result = Return (int_to_u32 4294967295) -End -Definition core_num_u32_max_c_def: - core_num_u32_max_c : u32 = get_return_value core_num_u32_max_body -End - val [hashmap_hash_map_move_elements_from_list_loop_fwd_back_def] = DefineDiv ‘ (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) @@ -271,7 +263,7 @@ val hashmap_hash_map_try_resize_fwd_back_def = Define ‘ hashmap_hash_map_try_resize_fwd_back (self : 't hashmap_hash_map_t) : 't hashmap_hash_map_t result = do - max_usize <- mk_usize (u32_to_int core_num_u32_max_c); + max_usize <- mk_usize (u32_to_int core_u32_max); let capacity = vec_len self.hashmap_hash_map_slots in do n1 <- usize_div max_usize (int_to_usize 2); diff --git a/tests/hol4/hashmap_on_disk/hashmapMain_FunsTheory.sig b/tests/hol4/hashmap_on_disk/hashmapMain_FunsTheory.sig index 1d24cb26..d4e43d9a 100644 --- a/tests/hol4/hashmap_on_disk/hashmapMain_FunsTheory.sig +++ b/tests/hol4/hashmap_on_disk/hashmapMain_FunsTheory.sig @@ -3,8 +3,6 @@ sig type thm = Thm.thm (* Definitions *) - val core_num_u32_max_body_def : thm - val core_num_u32_max_c_def : thm val hashmap_hash_key_fwd_def : thm val hashmap_hash_map_allocate_slots_fwd_def : thm val hashmap_hash_map_allocate_slots_loop_fwd_def : thm @@ -50,14 +48,6 @@ sig (* [hashmapMain_Opaque] Parent theory of "hashmapMain_Funs" - [core_num_u32_max_body_def] Definition - - ⊢ core_num_u32_max_body = Return (int_to_u32 4294967295) - - [core_num_u32_max_c_def] Definition - - ⊢ core_num_u32_max_c = get_return_value core_num_u32_max_body - [hashmap_hash_key_fwd_def] Definition ⊢ ∀k. hashmap_hash_key_fwd k = Return k @@ -506,7 +496,7 @@ sig ⊢ ∀self. hashmap_hash_map_try_resize_fwd_back self = do - max_usize <- mk_usize (u32_to_int core_num_u32_max_c); + max_usize <- mk_usize (u32_to_int core_u32_max); capacity <<- vec_len self.hashmap_hash_map_slots; n1 <- usize_div max_usize (int_to_usize 2); (i,i0) <<- self.hashmap_hash_map_max_load_factor; diff --git a/tests/hol4/misc-constants/constantsScript.sml b/tests/hol4/misc-constants/constantsScript.sml index d589d348..40a319c6 100644 --- a/tests/hol4/misc-constants/constantsScript.sml +++ b/tests/hol4/misc-constants/constantsScript.sml @@ -13,17 +13,9 @@ Definition x0_c_def: x0_c : u32 = get_return_value x0_body End -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body_def: - core_num_u32_max_body : u32 result = Return (int_to_u32 4294967295) -End -Definition core_num_u32_max_c_def: - core_num_u32_max_c : u32 = get_return_value core_num_u32_max_body -End - (** [constants::X1] *) Definition x1_body_def: - x1_body : u32 result = Return core_num_u32_max_c + x1_body : u32 result = Return core_u32_max End Definition x1_c_def: x1_c : u32 = get_return_value x1_body diff --git a/tests/hol4/misc-constants/constantsTheory.sig b/tests/hol4/misc-constants/constantsTheory.sig index 149d7e22..287ad5f5 100644 --- a/tests/hol4/misc-constants/constantsTheory.sig +++ b/tests/hol4/misc-constants/constantsTheory.sig @@ -4,8 +4,6 @@ sig (* Definitions *) val add_fwd_def : thm - val core_num_u32_max_body_def : thm - val core_num_u32_max_c_def : thm val get_z1_fwd_def : thm val get_z1_z1_body_def : thm val get_z1_z1_c_def : thm @@ -110,14 +108,6 @@ sig ⊢ ∀a b. add_fwd a b = i32_add a b - [core_num_u32_max_body_def] Definition - - ⊢ core_num_u32_max_body = Return (int_to_u32 4294967295) - - [core_num_u32_max_c_def] Definition - - ⊢ core_num_u32_max_c = get_return_value core_num_u32_max_body - [get_z1_fwd_def] Definition ⊢ get_z1_fwd = Return get_z1_z1_c @@ -321,7 +311,7 @@ sig [x1_body_def] Definition - ⊢ x1_body = Return core_num_u32_max_c + ⊢ x1_body = Return core_u32_max [x1_c_def] Definition diff --git a/tests/lean/Array.lean b/tests/lean/Array.lean index 277b63d9..20f02e97 100644 --- a/tests/lean/Array.lean +++ b/tests/lean/Array.lean @@ -1 +1,435 @@ -import Array.Funs +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [array] +import Base +open Primitives + +namespace array + +/- [array::AB] -/ +inductive AB := +| A : AB +| B : AB + +/- [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def incr (x : U32) : Result U32 := + x + 1#u32 + +/- [array::array_to_shared_slice_]: forward function -/ +def array_to_shared_slice_ + (T : Type) (s : Array T 32#usize) : Result (Slice T) := + Array.to_slice T 32#usize s + +/- [array::array_to_mut_slice_]: forward function -/ +def array_to_mut_slice_ (T : Type) (s : Array T 32#usize) : Result (Slice T) := + Array.to_slice T 32#usize s + +/- [array::array_to_mut_slice_]: backward function 0 -/ +def array_to_mut_slice__back + (T : Type) (s : Array T 32#usize) (ret0 : Slice T) : + Result (Array T 32#usize) + := + Array.from_slice T 32#usize s ret0 + +/- [array::array_len]: forward function -/ +def array_len (T : Type) (s : Array T 32#usize) : Result Usize := + do + let s0 ← Array.to_slice T 32#usize s + let i := Slice.len T s0 + Result.ret i + +/- [array::shared_array_len]: forward function -/ +def shared_array_len (T : Type) (s : Array T 32#usize) : Result Usize := + do + let s0 ← Array.to_slice T 32#usize s + let i := Slice.len T s0 + Result.ret i + +/- [array::shared_slice_len]: forward function -/ +def shared_slice_len (T : Type) (s : Slice T) : Result Usize := + let i := Slice.len T s + Result.ret i + +/- [array::index_array_shared]: forward function -/ +def index_array_shared + (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := + Array.index_usize T 32#usize s i + +/- [array::index_array_u32]: forward function -/ +def index_array_u32 (s : Array U32 32#usize) (i : Usize) : Result U32 := + Array.index_usize U32 32#usize s i + +/- [array::index_array_copy]: forward function -/ +def index_array_copy (x : Array U32 32#usize) : Result U32 := + Array.index_usize U32 32#usize x 0#usize + +/- [array::index_mut_array]: forward function -/ +def index_mut_array (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := + Array.index_usize T 32#usize s i + +/- [array::index_mut_array]: backward function 0 -/ +def index_mut_array_back + (T : Type) (s : Array T 32#usize) (i : Usize) (ret0 : T) : + Result (Array T 32#usize) + := + Array.update_usize T 32#usize s i ret0 + +/- [array::index_slice]: forward function -/ +def index_slice (T : Type) (s : Slice T) (i : Usize) : Result T := + Slice.index_usize T s i + +/- [array::index_mut_slice]: forward function -/ +def index_mut_slice (T : Type) (s : Slice T) (i : Usize) : Result T := + Slice.index_usize T s i + +/- [array::index_mut_slice]: backward function 0 -/ +def index_mut_slice_back + (T : Type) (s : Slice T) (i : Usize) (ret0 : T) : Result (Slice T) := + Slice.update_usize T s i ret0 + +/- [array::slice_subslice_shared_]: forward function -/ +def slice_subslice_shared_ + (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := + core.slice.index.Slice.index U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } + +/- [array::slice_subslice_mut_]: forward function -/ +def slice_subslice_mut_ + (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := + core.slice.index.Slice.index_mut U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } + +/- [array::slice_subslice_mut_]: backward function 0 -/ +def slice_subslice_mut__back + (x : Slice U32) (y : Usize) (z : Usize) (ret0 : Slice U32) : + Result (Slice U32) + := + core.slice.index.Slice.index_mut_back U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } ret0 + +/- [array::array_to_slice_shared_]: forward function -/ +def array_to_slice_shared_ (x : Array U32 32#usize) : Result (Slice U32) := + Array.to_slice U32 32#usize x + +/- [array::array_to_slice_mut_]: forward function -/ +def array_to_slice_mut_ (x : Array U32 32#usize) : Result (Slice U32) := + Array.to_slice U32 32#usize x + +/- [array::array_to_slice_mut_]: backward function 0 -/ +def array_to_slice_mut__back + (x : Array U32 32#usize) (ret0 : Slice U32) : Result (Array U32 32#usize) := + Array.from_slice U32 32#usize x ret0 + +/- [array::array_subslice_shared_]: forward function -/ +def array_subslice_shared_ + (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } + +/- [array::array_subslice_mut_]: forward function -/ +def array_subslice_mut_ + (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index_mut U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } + +/- [array::array_subslice_mut_]: backward function 0 -/ +def array_subslice_mut__back + (x : Array U32 32#usize) (y : Usize) (z : Usize) (ret0 : Slice U32) : + Result (Array U32 32#usize) + := + core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } ret0 + +/- [array::index_slice_0]: forward function -/ +def index_slice_0 (T : Type) (s : Slice T) : Result T := + Slice.index_usize T s 0#usize + +/- [array::index_array_0]: forward function -/ +def index_array_0 (T : Type) (s : Array T 32#usize) : Result T := + Array.index_usize T 32#usize s 0#usize + +/- [array::index_index_array]: forward function -/ +def index_index_array + (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : + Result U32 + := + do + let a ← Array.index_usize (Array U32 32#usize) 32#usize s i + Array.index_usize U32 32#usize a j + +/- [array::update_update_array]: forward function -/ +def update_update_array + (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : + Result Unit + := + do + let a ← Array.index_usize (Array U32 32#usize) 32#usize s i + let a0 ← Array.update_usize U32 32#usize a j 0#u32 + let _ ← Array.update_usize (Array U32 32#usize) 32#usize s i a0 + Result.ret () + +/- [array::array_local_deep_copy]: forward function -/ +def array_local_deep_copy (x : Array U32 32#usize) : Result Unit := + Result.ret () + +/- [array::take_array]: forward function -/ +def take_array (a : Array U32 2#usize) : Result Unit := + Result.ret () + +/- [array::take_array_borrow]: forward function -/ +def take_array_borrow (a : Array U32 2#usize) : Result Unit := + Result.ret () + +/- [array::take_slice]: forward function -/ +def take_slice (s : Slice U32) : Result Unit := + Result.ret () + +/- [array::take_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def take_mut_slice (s : Slice U32) : Result (Slice U32) := + Result.ret s + +/- [array::take_all]: forward function -/ +def take_all : Result Unit := + do + let _ ← take_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let _ ← take_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let _ ← take_slice s + let s0 ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s1 ← take_mut_slice s0 + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + Result.ret () + +/- [array::index_array]: forward function -/ +def index_array (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize + +/- [array::index_array_borrow]: forward function -/ +def index_array_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize + +/- [array::index_slice_u32_0]: forward function -/ +def index_slice_u32_0 (x : Slice U32) : Result U32 := + Slice.index_usize U32 x 0#usize + +/- [array::index_mut_slice_u32_0]: forward function -/ +def index_mut_slice_u32_0 (x : Slice U32) : Result U32 := + Slice.index_usize U32 x 0#usize + +/- [array::index_mut_slice_u32_0]: backward function 0 -/ +def index_mut_slice_u32_0_back (x : Slice U32) : Result (Slice U32) := + do + let _ ← Slice.index_usize U32 x 0#usize + Result.ret x + +/- [array::index_all]: forward function -/ +def index_all : Result U32 := + do + let i ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i0 ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i1 ← i + i0 + let i2 ← index_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i3 ← i1 + i2 + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i4 ← index_slice_u32_0 s + let i5 ← i3 + i4 + let s0 ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i6 ← index_mut_slice_u32_0 s0 + let i7 ← i5 + i6 + let s1 ← index_mut_slice_u32_0_back s0 + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + Result.ret i7 + +/- [array::update_array]: forward function -/ +def update_array (x : Array U32 2#usize) : Result Unit := + do + let _ ← Array.update_usize U32 2#usize x 0#usize 1#u32 + Result.ret () + +/- [array::update_array_mut_borrow]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def update_array_mut_borrow + (x : Array U32 2#usize) : Result (Array U32 2#usize) := + Array.update_usize U32 2#usize x 0#usize 1#u32 + +/- [array::update_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def update_mut_slice (x : Slice U32) : Result (Slice U32) := + Slice.update_usize U32 x 0#usize 1#u32 + +/- [array::update_all]: forward function -/ +def update_all : Result Unit := + do + let _ ← update_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let x ← update_array_mut_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s ← Array.to_slice U32 2#usize x + let s0 ← update_mut_slice s + let _ ← Array.from_slice U32 2#usize x s0 + Result.ret () + +/- [array::range_all]: forward function -/ +def range_all : Result Unit := + do + let s ← + core.array.Array.index_mut U32 (core.ops.range.Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 + (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) + { start := 1#usize, end_ := 3#usize } + let s0 ← update_mut_slice s + let _ ← + core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 + (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) + { start := 1#usize, end_ := 3#usize } s0 + Result.ret () + +/- [array::deref_array_borrow]: forward function -/ +def deref_array_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize + +/- [array::deref_array_mut_borrow]: forward function -/ +def deref_array_mut_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize + +/- [array::deref_array_mut_borrow]: backward function 0 -/ +def deref_array_mut_borrow_back + (x : Array U32 2#usize) : Result (Array U32 2#usize) := + do + let _ ← Array.index_usize U32 2#usize x 0#usize + Result.ret x + +/- [array::take_array_t]: forward function -/ +def take_array_t (a : Array AB 2#usize) : Result Unit := + Result.ret () + +/- [array::non_copyable_array]: forward function -/ +def non_copyable_array : Result Unit := + do + let _ ← take_array_t (Array.make AB 2#usize [ AB.A, AB.B ]) + Result.ret () + +/- [array::sum]: loop 0: forward function -/ +divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := + let i0 := Slice.len U32 s + if i < i0 + then + do + let i1 ← Slice.index_usize U32 s i + let sum1 ← sum0 + i1 + let i2 ← i + 1#usize + sum_loop s sum1 i2 + else Result.ret sum0 + +/- [array::sum]: forward function -/ +def sum (s : Slice U32) : Result U32 := + sum_loop s 0#u32 0#usize + +/- [array::sum2]: loop 0: forward function -/ +divergent def sum2_loop + (s : Slice U32) (s2 : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := + let i0 := Slice.len U32 s + if i < i0 + then + do + let i1 ← Slice.index_usize U32 s i + let i2 ← Slice.index_usize U32 s2 i + let i3 ← i1 + i2 + let sum1 ← sum0 + i3 + let i4 ← i + 1#usize + sum2_loop s s2 sum1 i4 + else Result.ret sum0 + +/- [array::sum2]: forward function -/ +def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := + let i := Slice.len U32 s + let i0 := Slice.len U32 s2 + if not (i = i0) + then Result.fail Error.panic + else sum2_loop s s2 0#u32 0#usize + +/- [array::f0]: forward function -/ +def f0 : Result Unit := + do + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← Slice.update_usize U32 s 0#usize 1#u32 + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) s0 + Result.ret () + +/- [array::f1]: forward function -/ +def f1 : Result Unit := + do + let _ ← + Array.update_usize U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + 0#usize 1#u32 + Result.ret () + +/- [array::f2]: forward function -/ +def f2 (i : U32) : Result Unit := + Result.ret () + +/- [array::f4]: forward function -/ +def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } + +/- [array::f3]: forward function -/ +def f3 : Result U32 := + do + let i ← + Array.index_usize U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + 0#usize + let _ ← f2 i + let b := Array.repeat U32 32#usize 0#u32 + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← f4 b 16#usize 18#usize + sum2 s s0 + +/- [array::SZ] -/ +def sz_body : Result Usize := Result.ret 32#usize +def sz_c : Usize := eval_global sz_body (by simp) + +/- [array::f5]: forward function -/ +def f5 (x : Array U32 32#usize) : Result U32 := + Array.index_usize U32 32#usize x 0#usize + +/- [array::ite]: forward function -/ +def ite : Result Unit := + do + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s0 ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s1 ← index_mut_slice_u32_0_back s0 + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + let s2 ← index_mut_slice_u32_0_back s + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s2 + Result.ret () + +end array diff --git a/tests/lean/Array/Funs.lean b/tests/lean/Array/Funs.lean index ad737dca..32ae6248 100644 --- a/tests/lean/Array/Funs.lean +++ b/tests/lean/Array/Funs.lean @@ -6,189 +6,183 @@ open Primitives namespace array +/- [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def incr (x : U32) : Result U32 := + x + 1#u32 + /- [array::array_to_shared_slice_]: forward function -/ def array_to_shared_slice_ - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result (Slice T0) := - Array.to_slice_shared T0 (Usize.ofInt 32) s + (T : Type) (s : Array T 32#usize) : Result (Slice T) := + Array.to_slice T 32#usize s /- [array::array_to_mut_slice_]: forward function -/ -def array_to_mut_slice_ - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result (Slice T0) := - Array.to_slice_mut T0 (Usize.ofInt 32) s +def array_to_mut_slice_ (T : Type) (s : Array T 32#usize) : Result (Slice T) := + Array.to_slice T 32#usize s /- [array::array_to_mut_slice_]: backward function 0 -/ def array_to_mut_slice__back - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) (ret0 : Slice T0) : - Result (Array T0 (Usize.ofInt 32)) + (T : Type) (s : Array T 32#usize) (ret0 : Slice T) : + Result (Array T 32#usize) := - Array.to_slice_mut_back T0 (Usize.ofInt 32) s ret0 + Array.from_slice T 32#usize s ret0 /- [array::array_len]: forward function -/ -def array_len (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result Usize := +def array_len (T : Type) (s : Array T 32#usize) : Result Usize := do - let s0 ← Array.to_slice_shared T0 (Usize.ofInt 32) s - let i := Slice.len T0 s0 + let s0 ← Array.to_slice T 32#usize s + let i := Slice.len T s0 Result.ret i /- [array::shared_array_len]: forward function -/ -def shared_array_len - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result Usize := +def shared_array_len (T : Type) (s : Array T 32#usize) : Result Usize := do - let s0 ← Array.to_slice_shared T0 (Usize.ofInt 32) s - let i := Slice.len T0 s0 + let s0 ← Array.to_slice T 32#usize s + let i := Slice.len T s0 Result.ret i /- [array::shared_slice_len]: forward function -/ -def shared_slice_len (T0 : Type) (s : Slice T0) : Result Usize := - let i := Slice.len T0 s +def shared_slice_len (T : Type) (s : Slice T) : Result Usize := + let i := Slice.len T s Result.ret i /- [array::index_array_shared]: forward function -/ def index_array_shared - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) (i : Usize) : Result T0 := - Array.index_shared T0 (Usize.ofInt 32) s i + (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := + Array.index_usize T 32#usize s i /- [array::index_array_u32]: forward function -/ -def index_array_u32 - (s : Array U32 (Usize.ofInt 32)) (i : Usize) : Result U32 := - Array.index_shared U32 (Usize.ofInt 32) s i - -/- [array::index_array_generic]: forward function -/ -def index_array_generic - (N : Usize) (s : Array U32 N) (i : Usize) : Result U32 := - Array.index_shared U32 N s i - -/- [array::index_array_generic_call]: forward function -/ -def index_array_generic_call - (N : Usize) (s : Array U32 N) (i : Usize) : Result U32 := - index_array_generic N s i +def index_array_u32 (s : Array U32 32#usize) (i : Usize) : Result U32 := + Array.index_usize U32 32#usize s i /- [array::index_array_copy]: forward function -/ -def index_array_copy (x : Array U32 (Usize.ofInt 32)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 32) x (Usize.ofInt 0) +def index_array_copy (x : Array U32 32#usize) : Result U32 := + Array.index_usize U32 32#usize x 0#usize /- [array::index_mut_array]: forward function -/ -def index_mut_array - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) (i : Usize) : Result T0 := - Array.index_mut T0 (Usize.ofInt 32) s i +def index_mut_array (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := + Array.index_usize T 32#usize s i /- [array::index_mut_array]: backward function 0 -/ def index_mut_array_back - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) (i : Usize) (ret0 : T0) : - Result (Array T0 (Usize.ofInt 32)) + (T : Type) (s : Array T 32#usize) (i : Usize) (ret0 : T) : + Result (Array T 32#usize) := - Array.index_mut_back T0 (Usize.ofInt 32) s i ret0 + Array.update_usize T 32#usize s i ret0 /- [array::index_slice]: forward function -/ -def index_slice (T0 : Type) (s : Slice T0) (i : Usize) : Result T0 := - Slice.index_shared T0 s i +def index_slice (T : Type) (s : Slice T) (i : Usize) : Result T := + Slice.index_usize T s i /- [array::index_mut_slice]: forward function -/ -def index_mut_slice (T0 : Type) (s : Slice T0) (i : Usize) : Result T0 := - Slice.index_mut T0 s i +def index_mut_slice (T : Type) (s : Slice T) (i : Usize) : Result T := + Slice.index_usize T s i /- [array::index_mut_slice]: backward function 0 -/ def index_mut_slice_back - (T0 : Type) (s : Slice T0) (i : Usize) (ret0 : T0) : Result (Slice T0) := - Slice.index_mut_back T0 s i ret0 + (T : Type) (s : Slice T) (i : Usize) (ret0 : T) : Result (Slice T) := + Slice.update_usize T s i ret0 /- [array::slice_subslice_shared_]: forward function -/ def slice_subslice_shared_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := - Slice.subslice_shared U32 x (Range.mk y z) + core.slice.index.Slice.index U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } /- [array::slice_subslice_mut_]: forward function -/ def slice_subslice_mut_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := - Slice.subslice_mut U32 x (Range.mk y z) + core.slice.index.Slice.index_mut U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } /- [array::slice_subslice_mut_]: backward function 0 -/ def slice_subslice_mut__back (x : Slice U32) (y : Usize) (z : Usize) (ret0 : Slice U32) : Result (Slice U32) := - Slice.subslice_mut_back U32 x (Range.mk y z) ret0 + core.slice.index.Slice.index_mut_back U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } ret0 /- [array::array_to_slice_shared_]: forward function -/ -def array_to_slice_shared_ - (x : Array U32 (Usize.ofInt 32)) : Result (Slice U32) := - Array.to_slice_shared U32 (Usize.ofInt 32) x +def array_to_slice_shared_ (x : Array U32 32#usize) : Result (Slice U32) := + Array.to_slice U32 32#usize x /- [array::array_to_slice_mut_]: forward function -/ -def array_to_slice_mut_ - (x : Array U32 (Usize.ofInt 32)) : Result (Slice U32) := - Array.to_slice_mut U32 (Usize.ofInt 32) x +def array_to_slice_mut_ (x : Array U32 32#usize) : Result (Slice U32) := + Array.to_slice U32 32#usize x /- [array::array_to_slice_mut_]: backward function 0 -/ def array_to_slice_mut__back - (x : Array U32 (Usize.ofInt 32)) (ret0 : Slice U32) : - Result (Array U32 (Usize.ofInt 32)) - := - Array.to_slice_mut_back U32 (Usize.ofInt 32) x ret0 + (x : Array U32 32#usize) (ret0 : Slice U32) : Result (Array U32 32#usize) := + Array.from_slice U32 32#usize x ret0 /- [array::array_subslice_shared_]: forward function -/ def array_subslice_shared_ - (x : Array U32 (Usize.ofInt 32)) (y : Usize) (z : Usize) : - Result (Slice U32) - := - Array.subslice_shared U32 (Usize.ofInt 32) x (Range.mk y z) + (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } /- [array::array_subslice_mut_]: forward function -/ def array_subslice_mut_ - (x : Array U32 (Usize.ofInt 32)) (y : Usize) (z : Usize) : - Result (Slice U32) - := - Array.subslice_mut U32 (Usize.ofInt 32) x (Range.mk y z) + (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index_mut U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } /- [array::array_subslice_mut_]: backward function 0 -/ def array_subslice_mut__back - (x : Array U32 (Usize.ofInt 32)) (y : Usize) (z : Usize) (ret0 : Slice U32) : - Result (Array U32 (Usize.ofInt 32)) + (x : Array U32 32#usize) (y : Usize) (z : Usize) (ret0 : Slice U32) : + Result (Array U32 32#usize) := - Array.subslice_mut_back U32 (Usize.ofInt 32) x (Range.mk y z) ret0 + core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } ret0 /- [array::index_slice_0]: forward function -/ -def index_slice_0 (T0 : Type) (s : Slice T0) : Result T0 := - Slice.index_shared T0 s (Usize.ofInt 0) +def index_slice_0 (T : Type) (s : Slice T) : Result T := + Slice.index_usize T s 0#usize /- [array::index_array_0]: forward function -/ -def index_array_0 (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result T0 := - Array.index_shared T0 (Usize.ofInt 32) s (Usize.ofInt 0) +def index_array_0 (T : Type) (s : Array T 32#usize) : Result T := + Array.index_usize T 32#usize s 0#usize /- [array::index_index_array]: forward function -/ def index_index_array - (s : Array (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32)) (i : Usize) - (j : Usize) : + (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : Result U32 := do - let a ← - Array.index_shared (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32) s i - Array.index_shared U32 (Usize.ofInt 32) a j + let a ← Array.index_usize (Array U32 32#usize) 32#usize s i + Array.index_usize U32 32#usize a j /- [array::update_update_array]: forward function -/ def update_update_array - (s : Array (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32)) (i : Usize) - (j : Usize) : + (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : Result Unit := do - let a ← Array.index_mut (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32) s i - let a0 ← Array.index_mut_back U32 (Usize.ofInt 32) a j (U32.ofInt 0) - let _ ← - Array.index_mut_back (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32) s i a0 + let a ← Array.index_usize (Array U32 32#usize) 32#usize s i + let a0 ← Array.update_usize U32 32#usize a j 0#u32 + let _ ← Array.update_usize (Array U32 32#usize) 32#usize s i a0 Result.ret () /- [array::array_local_deep_copy]: forward function -/ -def array_local_deep_copy (x : Array U32 (Usize.ofInt 32)) : Result Unit := +def array_local_deep_copy (x : Array U32 32#usize) : Result Unit := Result.ret () /- [array::take_array]: forward function -/ -def take_array (a : Array U32 (Usize.ofInt 2)) : Result Unit := +def take_array (a : Array U32 2#usize) : Result Unit := Result.ret () /- [array::take_array_borrow]: forward function -/ -def take_array_borrow (a : Array U32 (Usize.ofInt 2)) : Result Unit := +def take_array_borrow (a : Array U32 2#usize) : Result Unit := Result.ret () /- [array::take_slice]: forward function -/ @@ -203,148 +197,131 @@ def take_mut_slice (s : Slice U32) : Result (Slice U32) := /- [array::take_all]: forward function -/ def take_all : Result Unit := do - let _ ← - take_array - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) - let _ ← - take_array_borrow - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + let _ ← take_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let _ ← take_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s ← - Array.to_slice_shared U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let _ ← take_slice s let s0 ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s1 ← take_mut_slice s0 let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s1 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 Result.ret () /- [array::index_array]: forward function -/ -def index_array (x : Array U32 (Usize.ofInt 2)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) +def index_array (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize /- [array::index_array_borrow]: forward function -/ -def index_array_borrow (x : Array U32 (Usize.ofInt 2)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) +def index_array_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize /- [array::index_slice_u32_0]: forward function -/ def index_slice_u32_0 (x : Slice U32) : Result U32 := - Slice.index_shared U32 x (Usize.ofInt 0) + Slice.index_usize U32 x 0#usize /- [array::index_mut_slice_u32_0]: forward function -/ def index_mut_slice_u32_0 (x : Slice U32) : Result U32 := - Slice.index_shared U32 x (Usize.ofInt 0) + Slice.index_usize U32 x 0#usize /- [array::index_mut_slice_u32_0]: backward function 0 -/ def index_mut_slice_u32_0_back (x : Slice U32) : Result (Slice U32) := do - let _ ← Slice.index_shared U32 x (Usize.ofInt 0) + let _ ← Slice.index_usize U32 x 0#usize Result.ret x /- [array::index_all]: forward function -/ def index_all : Result U32 := do - let i ← - index_array - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) - let i0 ← - index_array - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + let i ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i0 ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i1 ← i + i0 - let i2 ← - index_array_borrow - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + let i2 ← index_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i3 ← i1 + i2 let s ← - Array.to_slice_shared U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i4 ← index_slice_u32_0 s let i5 ← i3 + i4 let s0 ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i6 ← index_mut_slice_u32_0 s0 let i7 ← i5 + i6 let s1 ← index_mut_slice_u32_0_back s0 let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s1 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 Result.ret i7 /- [array::update_array]: forward function -/ -def update_array (x : Array U32 (Usize.ofInt 2)) : Result Unit := +def update_array (x : Array U32 2#usize) : Result Unit := do - let _ ← - Array.index_mut_back U32 (Usize.ofInt 2) x (Usize.ofInt 0) (U32.ofInt 1) + let _ ← Array.update_usize U32 2#usize x 0#usize 1#u32 Result.ret () /- [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def update_array_mut_borrow - (x : Array U32 (Usize.ofInt 2)) : Result (Array U32 (Usize.ofInt 2)) := - Array.index_mut_back U32 (Usize.ofInt 2) x (Usize.ofInt 0) (U32.ofInt 1) + (x : Array U32 2#usize) : Result (Array U32 2#usize) := + Array.update_usize U32 2#usize x 0#usize 1#u32 /- [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def update_mut_slice (x : Slice U32) : Result (Slice U32) := - Slice.index_mut_back U32 x (Usize.ofInt 0) (U32.ofInt 1) + Slice.update_usize U32 x 0#usize 1#u32 /- [array::update_all]: forward function -/ def update_all : Result Unit := do - let _ ← - update_array - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) - let x ← - update_array_mut_borrow - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) - let s ← Array.to_slice_mut U32 (Usize.ofInt 2) x + let _ ← update_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let x ← update_array_mut_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s ← Array.to_slice U32 2#usize x let s0 ← update_mut_slice s - let _ ← Array.to_slice_mut_back U32 (Usize.ofInt 2) x s0 + let _ ← Array.from_slice U32 2#usize x s0 Result.ret () /- [array::range_all]: forward function -/ def range_all : Result Unit := do let s ← - Array.subslice_mut U32 (Usize.ofInt 4) - (Array.make U32 (Usize.ofInt 4) [ - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0) - ]) (Range.mk (Usize.ofInt 1) (Usize.ofInt 3)) + core.array.Array.index_mut U32 (core.ops.range.Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 + (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) + { start := 1#usize, end_ := 3#usize } let s0 ← update_mut_slice s let _ ← - Array.subslice_mut_back U32 (Usize.ofInt 4) - (Array.make U32 (Usize.ofInt 4) [ - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0) - ]) (Range.mk (Usize.ofInt 1) (Usize.ofInt 3)) s0 + core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 + (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) + { start := 1#usize, end_ := 3#usize } s0 Result.ret () /- [array::deref_array_borrow]: forward function -/ -def deref_array_borrow (x : Array U32 (Usize.ofInt 2)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) +def deref_array_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize /- [array::deref_array_mut_borrow]: forward function -/ -def deref_array_mut_borrow (x : Array U32 (Usize.ofInt 2)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) +def deref_array_mut_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize /- [array::deref_array_mut_borrow]: backward function 0 -/ def deref_array_mut_borrow_back - (x : Array U32 (Usize.ofInt 2)) : Result (Array U32 (Usize.ofInt 2)) := + (x : Array U32 2#usize) : Result (Array U32 2#usize) := do - let _ ← Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) + let _ ← Array.index_usize U32 2#usize x 0#usize Result.ret x /- [array::take_array_t]: forward function -/ -def take_array_t (a : Array T (Usize.ofInt 2)) : Result Unit := +def take_array_t (a : Array AB 2#usize) : Result Unit := Result.ret () /- [array::non_copyable_array]: forward function -/ def non_copyable_array : Result Unit := do - let _ ← take_array_t (Array.make T (Usize.ofInt 2) [ T.A, T.B ]) + let _ ← take_array_t (Array.make AB 2#usize [ AB.A, AB.B ]) Result.ret () /- [array::sum]: loop 0: forward function -/ @@ -353,15 +330,15 @@ divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := if i < i0 then do - let i1 ← Slice.index_shared U32 s i + let i1 ← Slice.index_usize U32 s i let sum1 ← sum0 + i1 - let i2 ← i + (Usize.ofInt 1) + let i2 ← i + 1#usize sum_loop s sum1 i2 else Result.ret sum0 /- [array::sum]: forward function -/ def sum (s : Slice U32) : Result U32 := - sum_loop s (U32.ofInt 0) (Usize.ofInt 0) + sum_loop s 0#u32 0#usize /- [array::sum2]: loop 0: forward function -/ divergent def sum2_loop @@ -370,11 +347,11 @@ divergent def sum2_loop if i < i0 then do - let i1 ← Slice.index_shared U32 s i - let i2 ← Slice.index_shared U32 s2 i + let i1 ← Slice.index_usize U32 s i + let i2 ← Slice.index_usize U32 s2 i let i3 ← i1 + i2 let sum1 ← sum0 + i3 - let i4 ← i + (Usize.ofInt 1) + let i4 ← i + 1#usize sum2_loop s s2 sum1 i4 else Result.ret sum0 @@ -384,27 +361,24 @@ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := let i0 := Slice.len U32 s2 if not (i = i0) then Result.fail Error.panic - else sum2_loop s s2 (U32.ofInt 0) (Usize.ofInt 0) + else sum2_loop s s2 0#u32 0#usize /- [array::f0]: forward function -/ def f0 : Result Unit := do let s ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - let s0 ← Slice.index_mut_back U32 s (Usize.ofInt 0) (U32.ofInt 1) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← Slice.update_usize U32 s 0#usize 1#u32 let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) s0 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) s0 Result.ret () /- [array::f1]: forward function -/ def f1 : Result Unit := do let _ ← - Array.index_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - (Usize.ofInt 0) (U32.ofInt 1) + Array.update_usize U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + 0#usize 1#u32 Result.ret () /- [array::f2]: forward function -/ @@ -412,54 +386,46 @@ def f2 (i : U32) : Result Unit := Result.ret () /- [array::f4]: forward function -/ -def f4 - (x : Array U32 (Usize.ofInt 32)) (y : Usize) (z : Usize) : - Result (Slice U32) - := - Array.subslice_shared U32 (Usize.ofInt 32) x (Range.mk y z) +def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } /- [array::f3]: forward function -/ def f3 : Result U32 := do let i ← - Array.index_shared U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - (Usize.ofInt 0) + Array.index_usize U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + 0#usize let _ ← f2 i + let b := Array.repeat U32 32#usize 0#u32 let s ← - Array.to_slice_shared U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - let s0 ← - f4 - (Array.make U32 (Usize.ofInt 32) [ - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0) - ]) (Usize.ofInt 16) (Usize.ofInt 18) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← f4 b 16#usize 18#usize sum2 s s0 +/- [array::SZ] -/ +def sz_body : Result Usize := Result.ret 32#usize +def sz_c : Usize := eval_global sz_body (by simp) + +/- [array::f5]: forward function -/ +def f5 (x : Array U32 32#usize) : Result U32 := + Array.index_usize U32 32#usize x 0#usize + /- [array::ite]: forward function -/ def ite : Result Unit := do let s ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s0 ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s1 ← index_mut_slice_u32_0_back s0 let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s1 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 let s2 ← index_mut_slice_u32_0_back s let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s2 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s2 Result.ret () end array diff --git a/tests/lean/Array/Types.lean b/tests/lean/Array/Types.lean index 72241276..60fa81ab 100644 --- a/tests/lean/Array/Types.lean +++ b/tests/lean/Array/Types.lean @@ -5,9 +5,9 @@ open Primitives namespace array -/- [array::T] -/ -inductive T := -| A : T -| B : T +/- [array::AB] -/ +inductive AB := +| A : AB +| B : AB end array diff --git a/tests/lean/BetreeMain/Funs.lean b/tests/lean/BetreeMain/Funs.lean index 07ef08dc..0901d449 100644 --- a/tests/lean/BetreeMain/Funs.lean +++ b/tests/lean/BetreeMain/Funs.lean @@ -40,77 +40,71 @@ def betree.store_leaf_node /- [betree_main::betree::fresh_node_id]: forward function -/ def betree.fresh_node_id (counter : U64) : Result U64 := do - let _ ← counter + (U64.ofInt 1) + let _ ← counter + 1#u64 Result.ret counter /- [betree_main::betree::fresh_node_id]: backward function 0 -/ def betree.fresh_node_id_back (counter : U64) : Result U64 := - counter + (U64.ofInt 1) + counter + 1#u64 /- [betree_main::betree::NodeIdCounter::{0}::new]: forward function -/ def betree.NodeIdCounter.new : Result betree.NodeIdCounter := - Result.ret { next_node_id := (U64.ofInt 0) } + Result.ret { next_node_id := 0#u64 } /- [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function -/ def betree.NodeIdCounter.fresh_id (self : betree.NodeIdCounter) : Result U64 := do - let _ ← self.next_node_id + (U64.ofInt 1) + let _ ← self.next_node_id + 1#u64 Result.ret self.next_node_id /- [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 -/ def betree.NodeIdCounter.fresh_id_back (self : betree.NodeIdCounter) : Result betree.NodeIdCounter := do - let i ← self.next_node_id + (U64.ofInt 1) + let i ← self.next_node_id + 1#u64 Result.ret { next_node_id := i } -/- [core::num::u64::{9}::MAX] -/ -def core_num_u64_max_body : Result U64 := - Result.ret (U64.ofInt 18446744073709551615) -def core_num_u64_max_c : U64 := eval_global core_num_u64_max_body (by simp) - /- [betree_main::betree::upsert_update]: forward function -/ def betree.upsert_update (prev : Option U64) (st : betree.UpsertFunState) : Result U64 := match prev with - | Option.none => + | none => match st with | betree.UpsertFunState.Add v => Result.ret v - | betree.UpsertFunState.Sub i => Result.ret (U64.ofInt 0) - | Option.some prev0 => + | betree.UpsertFunState.Sub i => Result.ret 0#u64 + | some prev0 => match st with | betree.UpsertFunState.Add v => do - let margin ← core_num_u64_max_c - prev0 + let margin ← core_u64_max - prev0 if margin >= v then prev0 + v - else Result.ret core_num_u64_max_c + else Result.ret core_u64_max | betree.UpsertFunState.Sub v => if prev0 >= v then prev0 - v - else Result.ret (U64.ofInt 0) + else Result.ret 0#u64 /- [betree_main::betree::List::{1}::len]: forward function -/ divergent def betree.List.len (T : Type) (self : betree.List T) : Result U64 := match self with - | betree.List.Cons t tl => - do - let i ← betree.List.len T tl - (U64.ofInt 1) + i - | betree.List.Nil => Result.ret (U64.ofInt 0) + | betree.List.Cons t tl => do + let i ← betree.List.len T tl + 1#u64 + i + | betree.List.Nil => Result.ret 0#u64 /- [betree_main::betree::List::{1}::split_at]: forward function -/ divergent def betree.List.split_at (T : Type) (self : betree.List T) (n : U64) : Result ((betree.List T) × (betree.List T)) := - if n = (U64.ofInt 0) + if n = 0#u64 then Result.ret (betree.List.Nil, self) else match self with | betree.List.Cons hd tl => do - let i ← n - (U64.ofInt 1) + let i ← n - 1#u64 let p ← betree.List.split_at T tl i let (ls0, ls1) := p let l := ls0 @@ -121,13 +115,13 @@ divergent def betree.List.split_at (there is a single backward function, and the forward function returns ()) -/ def betree.List.push_front (T : Type) (self : betree.List T) (x : T) : Result (betree.List T) := - let tl := mem.replace (betree.List T) self betree.List.Nil + let tl := core.mem.replace (betree.List T) self betree.List.Nil let l := tl Result.ret (betree.List.Cons x l) /- [betree_main::betree::List::{1}::pop_front]: forward function -/ def betree.List.pop_front (T : Type) (self : betree.List T) : Result T := - let ls := mem.replace (betree.List T) self betree.List.Nil + let ls := core.mem.replace (betree.List T) self betree.List.Nil match ls with | betree.List.Cons x tl => Result.ret x | betree.List.Nil => Result.fail Error.panic @@ -135,7 +129,7 @@ def betree.List.pop_front (T : Type) (self : betree.List T) : Result T := /- [betree_main::betree::List::{1}::pop_front]: backward function 0 -/ def betree.List.pop_front_back (T : Type) (self : betree.List T) : Result (betree.List T) := - let ls := mem.replace (betree.List T) self betree.List.Nil + let ls := core.mem.replace (betree.List T) self betree.List.Nil match ls with | betree.List.Cons x tl => Result.ret tl | betree.List.Nil => Result.fail Error.panic @@ -261,7 +255,7 @@ divergent def betree.Node.apply_upserts let v ← betree.upsert_update prev s let msgs0 ← betree.List.pop_front_back (U64 × betree.Message) msgs - betree.Node.apply_upserts msgs0 (Option.some v) key st + betree.Node.apply_upserts msgs0 (some v) key st else do let (st0, v) ← core.option.Option.unwrap U64 prev st @@ -291,7 +285,7 @@ divergent def betree.Node.apply_upserts_back let v ← betree.upsert_update prev s let msgs0 ← betree.List.pop_front_back (U64 × betree.Message) msgs - betree.Node.apply_upserts_back msgs0 (Option.some v) key st + betree.Node.apply_upserts_back msgs0 (some v) key st else do let (_, v) ← core.option.Option.unwrap U64 prev st @@ -305,12 +299,12 @@ divergent def betree.Node.lookup_in_bindings | betree.List.Cons hd tl => let (i, i0) := hd if i = key - then Result.ret (Option.some i0) + then Result.ret (some i0) else if i > key - then Result.ret Option.none + then Result.ret none else betree.Node.lookup_in_bindings key tl - | betree.List.Nil => Result.ret Option.none + | betree.List.Nil => Result.ret none /- [betree_main::betree::Internal::{4}::lookup_in_children]: forward function -/ mutual divergent def betree.Internal.lookup_in_children @@ -353,13 +347,13 @@ divergent def betree.Node.lookup if k != key then do - let (st1, opt) ← + let (st1, o) ← betree.Internal.lookup_in_children (betree.Internal.mk i i0 n n0) key st0 let _ ← betree.Node.lookup_first_message_for_key_back key msgs (betree.List.Cons (k, msg) l) - Result.ret (st1, opt) + Result.ret (st1, o) else match msg with | betree.Message.Insert v => @@ -367,13 +361,13 @@ divergent def betree.Node.lookup let _ ← betree.Node.lookup_first_message_for_key_back key msgs (betree.List.Cons (k, betree.Message.Insert v) l) - Result.ret (st0, Option.some v) + Result.ret (st0, some v) | betree.Message.Delete => do let _ ← betree.Node.lookup_first_message_for_key_back key msgs (betree.List.Cons (k, betree.Message.Delete) l) - Result.ret (st0, Option.none) + Result.ret (st0, none) | betree.Message.Upsert ufs => do let (st1, v) ← @@ -392,21 +386,21 @@ divergent def betree.Node.lookup let msgs0 ← betree.Node.lookup_first_message_for_key_back key msgs pending0 let (st3, _) ← betree.store_internal_node i1 msgs0 st2 - Result.ret (st3, Option.some v0) + Result.ret (st3, some v0) | betree.List.Nil => do - let (st1, opt) ← + let (st1, o) ← betree.Internal.lookup_in_children (betree.Internal.mk i i0 n n0) key st0 let _ ← betree.Node.lookup_first_message_for_key_back key msgs betree.List.Nil - Result.ret (st1, opt) + Result.ret (st1, o) | betree.Node.Leaf node => do let (st0, bindings) ← betree.load_leaf_node node.id st - let opt ← betree.Node.lookup_in_bindings key bindings - Result.ret (st0, opt) + let o ← betree.Node.lookup_in_bindings key bindings + Result.ret (st0, o) /- [betree_main::betree::Node::{5}::lookup]: backward function 0 -/ divergent def betree.Node.lookup_back @@ -565,7 +559,7 @@ def betree.Node.apply_to_internal match m with | betree.Message.Insert prev => do - let v ← betree.upsert_update (Option.some prev) s + let v ← betree.upsert_update (some prev) s let msgs1 ← betree.List.pop_front_back (U64 × betree.Message) msgs0 let msgs2 ← @@ -574,7 +568,7 @@ def betree.Node.apply_to_internal betree.Node.lookup_first_message_for_key_back key msgs msgs2 | betree.Message.Delete => do - let v ← betree.upsert_update Option.none s + let v ← betree.upsert_update none s let msgs1 ← betree.List.pop_front_back (U64 × betree.Message) msgs0 let msgs2 ← @@ -670,7 +664,7 @@ def betree.Node.apply_to_leaf | betree.Message.Upsert s => do let (_, i) := hd - let v ← betree.upsert_update (Option.some i) s + let v ← betree.upsert_update (some i) s let bindings1 ← betree.List.pop_front_back (U64 × U64) bindings0 let bindings2 ← betree.List.push_front (U64 × U64) bindings1 (key, v) @@ -686,7 +680,7 @@ def betree.Node.apply_to_leaf betree.Node.lookup_mut_in_bindings_back key bindings bindings0 | betree.Message.Upsert s => do - let v ← betree.upsert_update Option.none s + let v ← betree.upsert_update none s let bindings1 ← betree.List.push_front (U64 × U64) bindings0 (key, v) betree.Node.lookup_mut_in_bindings_back key bindings bindings1 @@ -813,7 +807,7 @@ divergent def betree.Node.apply_messages let (st0, content) ← betree.load_leaf_node node.id st let content0 ← betree.Node.apply_messages_to_leaf content msgs let len ← betree.List.len (U64 × U64) content0 - let i ← (U64.ofInt 2) * params.split_size + let i ← 2#u64 * params.split_size if len >= i then do @@ -863,7 +857,7 @@ divergent def betree.Node.apply_messages_back let (st0, content) ← betree.load_leaf_node node.id st let content0 ← betree.Node.apply_messages_to_leaf content msgs let len ← betree.List.len (U64 × U64) content0 - let i ← (U64.ofInt 2) * params.split_size + let i ← 2#u64 * params.split_size if len >= i then do @@ -923,7 +917,7 @@ def betree.BeTree.new params := { min_flush_size := min_flush_size, split_size := split_size }, node_id_cnt := node_id_cnt0, - root := (betree.Node.Leaf { id := id, size := (U64.ofInt 0) }) + root := (betree.Node.Leaf { id := id, size := 0#u64 }) }) /- [betree_main::betree::BeTree::{6}::apply]: forward function -/ diff --git a/tests/lean/Constants.lean b/tests/lean/Constants.lean index 51b415d6..bd3a07b7 100644 --- a/tests/lean/Constants.lean +++ b/tests/lean/Constants.lean @@ -6,27 +6,23 @@ open Primitives namespace constants /- [constants::X0] -/ -def x0_body : Result U32 := Result.ret (U32.ofInt 0) +def x0_body : Result U32 := Result.ret 0#u32 def x0_c : U32 := eval_global x0_body (by simp) -/- [core::num::u32::{8}::MAX] -/ -def core_num_u32_max_body : Result U32 := Result.ret (U32.ofInt 4294967295) -def core_num_u32_max_c : U32 := eval_global core_num_u32_max_body (by simp) - /- [constants::X1] -/ -def x1_body : Result U32 := Result.ret core_num_u32_max_c +def x1_body : Result U32 := Result.ret core_u32_max def x1_c : U32 := eval_global x1_body (by simp) /- [constants::X2] -/ -def x2_body : Result U32 := Result.ret (U32.ofInt 3) +def x2_body : Result U32 := Result.ret 3#u32 def x2_c : U32 := eval_global x2_body (by simp) /- [constants::incr]: forward function -/ def incr (n : U32) : Result U32 := - n + (U32.ofInt 1) + n + 1#u32 /- [constants::X3] -/ -def x3_body : Result U32 := incr (U32.ofInt 32) +def x3_body : Result U32 := incr 32#u32 def x3_c : U32 := eval_global x3_body (by simp) /- [constants::mk_pair0]: forward function -/ @@ -43,44 +39,43 @@ def mk_pair1 (x : U32) (y : U32) : Result (Pair U32 U32) := Result.ret { x := x, y := y } /- [constants::P0] -/ -def p0_body : Result (U32 × U32) := mk_pair0 (U32.ofInt 0) (U32.ofInt 1) +def p0_body : Result (U32 × U32) := mk_pair0 0#u32 1#u32 def p0_c : (U32 × U32) := eval_global p0_body (by simp) /- [constants::P1] -/ -def p1_body : Result (Pair U32 U32) := mk_pair1 (U32.ofInt 0) (U32.ofInt 1) +def p1_body : Result (Pair U32 U32) := mk_pair1 0#u32 1#u32 def p1_c : Pair U32 U32 := eval_global p1_body (by simp) /- [constants::P2] -/ -def p2_body : Result (U32 × U32) := Result.ret ((U32.ofInt 0), (U32.ofInt 1)) +def p2_body : Result (U32 × U32) := Result.ret (0#u32, 1#u32) def p2_c : (U32 × U32) := eval_global p2_body (by simp) /- [constants::P3] -/ -def p3_body : Result (Pair U32 U32) := - Result.ret { x := (U32.ofInt 0), y := (U32.ofInt 1) } +def p3_body : Result (Pair U32 U32) := Result.ret { x := 0#u32, y := 1#u32 } def p3_c : Pair U32 U32 := eval_global p3_body (by simp) /- [constants::Wrap] -/ structure Wrap (T : Type) where - val : T + value : T /- [constants::Wrap::{0}::new]: forward function -/ -def Wrap.new (T : Type) (val : T) : Result (Wrap T) := - Result.ret { val := val } +def Wrap.new (T : Type) (value : T) : Result (Wrap T) := + Result.ret { value := value } /- [constants::Y] -/ -def y_body : Result (Wrap I32) := Wrap.new I32 (I32.ofInt 2) +def y_body : Result (Wrap I32) := Wrap.new I32 2#i32 def y_c : Wrap I32 := eval_global y_body (by simp) /- [constants::unwrap_y]: forward function -/ def unwrap_y : Result I32 := - Result.ret y_c.val + Result.ret y_c.value /- [constants::YVAL] -/ def yval_body : Result I32 := unwrap_y def yval_c : I32 := eval_global yval_body (by simp) /- [constants::get_z1::Z1] -/ -def get_z1_z1_body : Result I32 := Result.ret (I32.ofInt 3) +def get_z1_z1_body : Result I32 := Result.ret 3#i32 def get_z1_z1_c : I32 := eval_global get_z1_z1_body (by simp) /- [constants::get_z1]: forward function -/ @@ -92,7 +87,7 @@ def add (a : I32) (b : I32) : Result I32 := a + b /- [constants::Q1] -/ -def q1_body : Result I32 := Result.ret (I32.ofInt 5) +def q1_body : Result I32 := Result.ret 5#i32 def q1_c : I32 := eval_global q1_body (by simp) /- [constants::Q2] -/ @@ -100,7 +95,7 @@ def q2_body : Result I32 := Result.ret q1_c def q2_c : I32 := eval_global q2_body (by simp) /- [constants::Q3] -/ -def q3_body : Result I32 := add q2_c (I32.ofInt 3) +def q3_body : Result I32 := add q2_c 3#i32 def q3_c : I32 := eval_global q3_body (by simp) /- [constants::get_z2]: forward function -/ @@ -111,7 +106,7 @@ def get_z2 : Result I32 := add q1_c i0 /- [constants::S1] -/ -def s1_body : Result U32 := Result.ret (U32.ofInt 6) +def s1_body : Result U32 := Result.ret 6#u32 def s1_c : U32 := eval_global s1_body (by simp) /- [constants::S2] -/ @@ -123,7 +118,7 @@ def s3_body : Result (Pair U32 U32) := Result.ret p3_c def s3_c : Pair U32 U32 := eval_global s3_body (by simp) /- [constants::S4] -/ -def s4_body : Result (Pair U32 U32) := mk_pair1 (U32.ofInt 7) (U32.ofInt 8) +def s4_body : Result (Pair U32 U32) := mk_pair1 7#u32 8#u32 def s4_c : Pair U32 U32 := eval_global s4_body (by simp) end constants diff --git a/tests/lean/External/Funs.lean b/tests/lean/External/Funs.lean index 055d7860..55fb07be 100644 --- a/tests/lean/External/Funs.lean +++ b/tests/lean/External/Funs.lean @@ -30,14 +30,14 @@ def swap_back def test_new_non_zero_u32 (x : U32) (st : State) : Result (State × core.num.nonzero.NonZeroU32) := do - let (st0, opt) ← core.num.nonzero.NonZeroU32.new x st - core.option.Option.unwrap core.num.nonzero.NonZeroU32 opt st0 + let (st0, o) ← core.num.nonzero.NonZeroU32.new x st + core.option.Option.unwrap core.num.nonzero.NonZeroU32 o st0 /- [external::test_vec]: forward function -/ def test_vec : Result Unit := do - let v := Vec.new U32 - let _ ← Vec.push U32 v (U32.ofInt 0) + let v := alloc.vec.Vec.new U32 + let _ ← alloc.vec.Vec.push U32 v 0#u32 Result.ret () /- Unit test for [external::test_vec] -/ @@ -75,14 +75,14 @@ def test_custom_swap_back (x : U32) (y : U32) (st : State) (st0 : State) : Result (State × (U32 × U32)) := - custom_swap_back U32 x y st (U32.ofInt 1) st0 + custom_swap_back U32 x y st 1#u32 st0 /- [external::test_swap_non_zero]: forward function -/ def test_swap_non_zero (x : U32) (st : State) : Result (State × U32) := do - let (st0, _) ← swap U32 x (U32.ofInt 0) st - let (st1, (x0, _)) ← swap_back U32 x (U32.ofInt 0) st st0 - if x0 = (U32.ofInt 0) + let (st0, _) ← swap U32 x 0#u32 st + let (st1, (x0, _)) ← swap_back U32 x 0#u32 st st0 + if x0 = 0#u32 then Result.fail Error.panic else Result.ret (st1, x0) diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index 30b30e0b..8464c432 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -12,18 +12,22 @@ def hash_key (k : Usize) : Result Usize := /- [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function -/ divergent def HashMap.allocate_slots_loop - (T : Type) (slots : Vec (List T)) (n : Usize) : Result (Vec (List T)) := - if n > (Usize.ofInt 0) + (T : Type) (slots : alloc.vec.Vec (List T)) (n : Usize) : + Result (alloc.vec.Vec (List T)) + := + if n > 0#usize then do - let slots0 ← Vec.push (List T) slots List.Nil - let n0 ← n - (Usize.ofInt 1) + let slots0 ← alloc.vec.Vec.push (List T) slots List.Nil + let n0 ← n - 1#usize HashMap.allocate_slots_loop T slots0 n0 else Result.ret slots /- [hashmap::HashMap::{0}::allocate_slots]: forward function -/ def HashMap.allocate_slots - (T : Type) (slots : Vec (List T)) (n : Usize) : Result (Vec (List T)) := + (T : Type) (slots : alloc.vec.Vec (List T)) (n : Usize) : + Result (alloc.vec.Vec (List T)) + := HashMap.allocate_slots_loop T slots n /- [hashmap::HashMap::{0}::new_with_capacity]: forward function -/ @@ -33,13 +37,13 @@ def HashMap.new_with_capacity Result (HashMap T) := do - let v := Vec.new (List T) + let v := alloc.vec.Vec.new (List T) let slots ← HashMap.allocate_slots T v capacity let i ← capacity * max_load_dividend let i0 ← i / max_load_divisor Result.ret { - num_entries := (Usize.ofInt 0), + num_entries := 0#usize, max_load_factor := (max_load_dividend, max_load_divisor), max_load := i0, slots := slots @@ -47,18 +51,23 @@ def HashMap.new_with_capacity /- [hashmap::HashMap::{0}::new]: forward function -/ def HashMap.new (T : Type) : Result (HashMap T) := - HashMap.new_with_capacity T (Usize.ofInt 32) (Usize.ofInt 4) (Usize.ofInt 5) + HashMap.new_with_capacity T 32#usize 4#usize 5#usize /- [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.clear_loop - (T : Type) (slots : Vec (List T)) (i : Usize) : Result (Vec (List T)) := - let i0 := Vec.len (List T) slots + (T : Type) (slots : alloc.vec.Vec (List T)) (i : Usize) : + Result (alloc.vec.Vec (List T)) + := + let i0 := alloc.vec.Vec.len (List T) slots if i < i0 then do - let i1 ← i + (Usize.ofInt 1) - let slots0 ← Vec.index_mut_back (List T) slots i List.Nil + let i1 ← i + 1#usize + let slots0 ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots + i List.Nil HashMap.clear_loop T slots0 i1 else Result.ret slots @@ -66,8 +75,8 @@ divergent def HashMap.clear_loop (there is a single backward function, and the forward function returns ()) -/ def HashMap.clear (T : Type) (self : HashMap T) : Result (HashMap T) := do - let v ← HashMap.clear_loop T self.slots (Usize.ofInt 0) - Result.ret { self with num_entries := (Usize.ofInt 0), slots := v } + let v ← HashMap.clear_loop T self.slots 0#usize + Result.ret { self with num_entries := 0#usize, slots := v } /- [hashmap::HashMap::{0}::len]: forward function -/ def HashMap.len (T : Type) (self : HashMap T) : Result Usize := @@ -115,27 +124,32 @@ def HashMap.insert_no_resize := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod let inserted ← HashMap.insert_in_list T key value l if inserted then do - let i0 ← self.num_entries + (Usize.ofInt 1) + let i0 ← self.num_entries + 1#usize let l0 ← HashMap.insert_in_list_back T key value l - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } else do let l0 ← HashMap.insert_in_list_back T key value l - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } -/- [core::num::u32::{8}::MAX] -/ -def core_num_u32_max_body : Result U32 := Result.ret (U32.ofInt 4294967295) -def core_num_u32_max_c : U32 := eval_global core_num_u32_max_body (by simp) - /- [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.move_elements_from_list_loop @@ -156,27 +170,35 @@ def HashMap.move_elements_from_list /- [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.move_elements_loop - (T : Type) (ntable : HashMap T) (slots : Vec (List T)) (i : Usize) : - Result ((HashMap T) × (Vec (List T))) + (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) + : + Result ((HashMap T) × (alloc.vec.Vec (List T))) := - let i0 := Vec.len (List T) slots + let i0 := alloc.vec.Vec.len (List T) slots if i < i0 then do - let l ← Vec.index_mut (List T) slots i - let ls := mem.replace (List T) l List.Nil + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots + i + let ls := core.mem.replace (List T) l List.Nil let ntable0 ← HashMap.move_elements_from_list T ntable ls - let i1 ← i + (Usize.ofInt 1) - let l0 := mem.replace_back (List T) l List.Nil - let slots0 ← Vec.index_mut_back (List T) slots i l0 + let i1 ← i + 1#usize + let l0 := core.mem.replace_back (List T) l List.Nil + let slots0 ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots + i l0 HashMap.move_elements_loop T ntable0 slots0 i1 else Result.ret (ntable, slots) /- [hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def HashMap.move_elements - (T : Type) (ntable : HashMap T) (slots : Vec (List T)) (i : Usize) : - Result ((HashMap T) × (Vec (List T))) + (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) + : + Result ((HashMap T) × (alloc.vec.Vec (List T))) := HashMap.move_elements_loop T ntable slots i @@ -184,18 +206,17 @@ def HashMap.move_elements (there is a single backward function, and the forward function returns ()) -/ def HashMap.try_resize (T : Type) (self : HashMap T) : Result (HashMap T) := do - let max_usize ← Scalar.cast .Usize core_num_u32_max_c - let capacity := Vec.len (List T) self.slots - let n1 ← max_usize / (Usize.ofInt 2) + let max_usize ← Scalar.cast .Usize core_u32_max + let capacity := alloc.vec.Vec.len (List T) self.slots + let n1 ← max_usize / 2#usize let (i, i0) := self.max_load_factor let i1 ← n1 / i if capacity <= i1 then do - let i2 ← capacity * (Usize.ofInt 2) + let i2 ← capacity * 2#usize let ntable ← HashMap.new_with_capacity T i2 i i0 - let (ntable0, _) ← - HashMap.move_elements T ntable self.slots (Usize.ofInt 0) + let (ntable0, _) ← HashMap.move_elements T ntable self.slots 0#usize Result.ret { ntable0 @@ -237,9 +258,12 @@ def HashMap.contains_key (T : Type) (self : HashMap T) (key : Usize) : Result Bool := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_shared (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod HashMap.contains_key_in_list T key l /- [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function -/ @@ -260,9 +284,12 @@ def HashMap.get_in_list (T : Type) (key : Usize) (ls : List T) : Result T := def HashMap.get (T : Type) (self : HashMap T) (key : Usize) : Result T := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_shared (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod HashMap.get_in_list T key l /- [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function -/ @@ -302,9 +329,12 @@ def HashMap.get_mut_in_list_back def HashMap.get_mut (T : Type) (self : HashMap T) (key : Usize) : Result T := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod HashMap.get_mut_in_list T l key /- [hashmap::HashMap::{0}::get_mut]: backward function 0 -/ @@ -314,11 +344,17 @@ def HashMap.get_mut_back := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod let l0 ← HashMap.get_mut_in_list_back T l key ret0 - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } /- [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function -/ @@ -328,12 +364,12 @@ divergent def HashMap.remove_from_list_loop | List.Cons ckey t tl => if ckey = key then - let mv_ls := mem.replace (List T) (List.Cons ckey t tl) List.Nil + let mv_ls := core.mem.replace (List T) (List.Cons ckey t tl) List.Nil match mv_ls with - | List.Cons i cvalue tl0 => Result.ret (Option.some cvalue) + | List.Cons i cvalue tl0 => Result.ret (some cvalue) | List.Nil => Result.fail Error.panic else HashMap.remove_from_list_loop T key tl - | List.Nil => Result.ret Option.none + | List.Nil => Result.ret none /- [hashmap::HashMap::{0}::remove_from_list]: forward function -/ def HashMap.remove_from_list @@ -347,7 +383,7 @@ divergent def HashMap.remove_from_list_loop_back | List.Cons ckey t tl => if ckey = key then - let mv_ls := mem.replace (List T) (List.Cons ckey t tl) List.Nil + let mv_ls := core.mem.replace (List T) (List.Cons ckey t tl) List.Nil match mv_ls with | List.Cons i cvalue tl0 => Result.ret tl0 | List.Nil => Result.fail Error.panic @@ -367,84 +403,91 @@ def HashMap.remove (T : Type) (self : HashMap T) (key : Usize) : Result (Option T) := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod let x ← HashMap.remove_from_list T key l match x with - | Option.none => Result.ret Option.none - | Option.some x0 => - do - let _ ← self.num_entries - (Usize.ofInt 1) - Result.ret (Option.some x0) + | none => Result.ret none + | some x0 => do + let _ ← self.num_entries - 1#usize + Result.ret (some x0) /- [hashmap::HashMap::{0}::remove]: backward function 0 -/ def HashMap.remove_back (T : Type) (self : HashMap T) (key : Usize) : Result (HashMap T) := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod let x ← HashMap.remove_from_list T key l match x with - | Option.none => + | none => do let l0 ← HashMap.remove_from_list_back T key l - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } - | Option.some x0 => + | some x0 => do - let i0 ← self.num_entries - (Usize.ofInt 1) + let i0 ← self.num_entries - 1#usize let l0 ← HashMap.remove_from_list_back T key l - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } /- [hashmap::test1]: forward function -/ def test1 : Result Unit := do let hm ← HashMap.new U64 - let hm0 ← HashMap.insert U64 hm (Usize.ofInt 0) (U64.ofInt 42) - let hm1 ← HashMap.insert U64 hm0 (Usize.ofInt 128) (U64.ofInt 18) - let hm2 ← HashMap.insert U64 hm1 (Usize.ofInt 1024) (U64.ofInt 138) - let hm3 ← HashMap.insert U64 hm2 (Usize.ofInt 1056) (U64.ofInt 256) - let i ← HashMap.get U64 hm3 (Usize.ofInt 128) - if not (i = (U64.ofInt 18)) + let hm0 ← HashMap.insert U64 hm 0#usize 42#u64 + let hm1 ← HashMap.insert U64 hm0 128#usize 18#u64 + let hm2 ← HashMap.insert U64 hm1 1024#usize 138#u64 + let hm3 ← HashMap.insert U64 hm2 1056#usize 256#u64 + let i ← HashMap.get U64 hm3 128#usize + if not (i = 18#u64) then Result.fail Error.panic else do - let hm4 ← - HashMap.get_mut_back U64 hm3 (Usize.ofInt 1024) (U64.ofInt 56) - let i0 ← HashMap.get U64 hm4 (Usize.ofInt 1024) - if not (i0 = (U64.ofInt 56)) + let hm4 ← HashMap.get_mut_back U64 hm3 1024#usize 56#u64 + let i0 ← HashMap.get U64 hm4 1024#usize + if not (i0 = 56#u64) then Result.fail Error.panic else do - let x ← HashMap.remove U64 hm4 (Usize.ofInt 1024) + let x ← HashMap.remove U64 hm4 1024#usize match x with - | Option.none => Result.fail Error.panic - | Option.some x0 => - if not (x0 = (U64.ofInt 56)) + | none => Result.fail Error.panic + | some x0 => + if not (x0 = 56#u64) then Result.fail Error.panic else do - let hm5 ← HashMap.remove_back U64 hm4 (Usize.ofInt 1024) - let i1 ← HashMap.get U64 hm5 (Usize.ofInt 0) - if not (i1 = (U64.ofInt 42)) + let hm5 ← HashMap.remove_back U64 hm4 1024#usize + let i1 ← HashMap.get U64 hm5 0#usize + if not (i1 = 42#u64) then Result.fail Error.panic else do - let i2 ← HashMap.get U64 hm5 (Usize.ofInt 128) - if not (i2 = (U64.ofInt 18)) + let i2 ← HashMap.get U64 hm5 128#usize + if not (i2 = 18#u64) then Result.fail Error.panic else do - let i3 ← HashMap.get U64 hm5 (Usize.ofInt 1056) - if not (i3 = (U64.ofInt 256)) + let i3 ← HashMap.get U64 hm5 1056#usize + if not (i3 = 256#u64) then Result.fail Error.panic else Result.ret () -/- Unit test for [hashmap::test1] -/ -#assert (test1 == .ret ()) - end hashmap diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index fe00ab14..e79c422d 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -157,7 +157,7 @@ instance : Inhabited (List α) where def slots_s_inv (s : Core.List (List α)) : Prop := ∀ (i : Int), 0 ≤ i → i < s.len → slot_t_inv s.len i (s.index i) -def slots_t_inv (s : Vec (List α)) : Prop := +def slots_t_inv (s : alloc.vec.Vec (List α)) : Prop := slots_s_inv s.v @[simp] @@ -302,20 +302,19 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value | none => nhm.len_s = hm.len_s + 1 | some _ => nhm.len_s = hm.len_s) := by rw [insert_no_resize] - simp only [hash_key, bind_tc_ret] -- TODO: annoying - have _ : (Vec.len (List α) hm.slots).val ≠ 0 := by checkpoint + -- Simplify. Note that this also simplifies some function calls, like array index + simp [hash_key, bind_tc_ret] + have _ : (alloc.vec.Vec.len (List α) hm.slots).val ≠ 0 := by intro simp_all [inv] - progress keep _ as ⟨ hash_mod, hhm ⟩ - have _ : 0 ≤ hash_mod.val := by checkpoint scalar_tac - have _ : hash_mod.val < Vec.length hm.slots := by + progress as ⟨ hash_mod, hhm ⟩ + have _ : 0 ≤ hash_mod.val := by scalar_tac + have _ : hash_mod.val < alloc.vec.Vec.length hm.slots := by have : 0 < hm.slots.val.len := by simp [inv] at hinv simp [hinv] -- TODO: we want to automate that simp [*, Int.emod_lt_of_pos] - -- TODO: change the spec of Vec.index_mut to introduce a let-binding. - -- or: make progress introduce the let-binding by itself (this is clearer) progress as ⟨ l, h_leq ⟩ -- TODO: make progress use the names written in the goal progress as ⟨ inserted ⟩ @@ -376,7 +375,7 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value -- TODO: we want to automate this simp apply Int.emod_nonneg k.val hvnz - have _ : k_hash_mod < Vec.length hm.slots := by + have _ : k_hash_mod < alloc.vec.Vec.length hm.slots := by -- TODO: we want to automate this simp have h := Int.emod_lt_of_pos k.val hvpos diff --git a/tests/lean/Hashmap/Types.lean b/tests/lean/Hashmap/Types.lean index 6455798d..e007bce0 100644 --- a/tests/lean/Hashmap/Types.lean +++ b/tests/lean/Hashmap/Types.lean @@ -15,6 +15,6 @@ structure HashMap (T : Type) where num_entries : Usize max_load_factor : (Usize × Usize) max_load : Usize - slots : Vec (List T) + slots : alloc.vec.Vec (List T) end hashmap diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index aec957ec..74fa8653 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -13,21 +13,21 @@ def hashmap.hash_key (k : Usize) : Result Usize := /- [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function -/ divergent def hashmap.HashMap.allocate_slots_loop - (T : Type) (slots : Vec (hashmap.List T)) (n : Usize) : - Result (Vec (hashmap.List T)) + (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (n : Usize) : + Result (alloc.vec.Vec (hashmap.List T)) := - if n > (Usize.ofInt 0) + if n > 0#usize then do - let slots0 ← Vec.push (hashmap.List T) slots hashmap.List.Nil - let n0 ← n - (Usize.ofInt 1) + let slots0 ← alloc.vec.Vec.push (hashmap.List T) slots hashmap.List.Nil + let n0 ← n - 1#usize hashmap.HashMap.allocate_slots_loop T slots0 n0 else Result.ret slots /- [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function -/ def hashmap.HashMap.allocate_slots - (T : Type) (slots : Vec (hashmap.List T)) (n : Usize) : - Result (Vec (hashmap.List T)) + (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (n : Usize) : + Result (alloc.vec.Vec (hashmap.List T)) := hashmap.HashMap.allocate_slots_loop T slots n @@ -38,13 +38,13 @@ def hashmap.HashMap.new_with_capacity Result (hashmap.HashMap T) := do - let v := Vec.new (hashmap.List T) + let v := alloc.vec.Vec.new (hashmap.List T) let slots ← hashmap.HashMap.allocate_slots T v capacity let i ← capacity * max_load_dividend let i0 ← i / max_load_divisor Result.ret { - num_entries := (Usize.ofInt 0), + num_entries := 0#usize, max_load_factor := (max_load_dividend, max_load_divisor), max_load := i0, slots := slots @@ -52,22 +52,23 @@ def hashmap.HashMap.new_with_capacity /- [hashmap_main::hashmap::HashMap::{0}::new]: forward function -/ def hashmap.HashMap.new (T : Type) : Result (hashmap.HashMap T) := - hashmap.HashMap.new_with_capacity T (Usize.ofInt 32) (Usize.ofInt 4) - (Usize.ofInt 5) + hashmap.HashMap.new_with_capacity T 32#usize 4#usize 5#usize /- [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.clear_loop - (T : Type) (slots : Vec (hashmap.List T)) (i : Usize) : - Result (Vec (hashmap.List T)) + (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : + Result (alloc.vec.Vec (hashmap.List T)) := - let i0 := Vec.len (hashmap.List T) slots + let i0 := alloc.vec.Vec.len (hashmap.List T) slots if i < i0 then do - let i1 ← i + (Usize.ofInt 1) + let i1 ← i + 1#usize let slots0 ← - Vec.index_mut_back (hashmap.List T) slots i hashmap.List.Nil + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) slots i hashmap.List.Nil hashmap.HashMap.clear_loop T slots0 i1 else Result.ret slots @@ -76,8 +77,8 @@ divergent def hashmap.HashMap.clear_loop def hashmap.HashMap.clear (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := do - let v ← hashmap.HashMap.clear_loop T self.slots (Usize.ofInt 0) - Result.ret { self with num_entries := (Usize.ofInt 0), slots := v } + let v ← hashmap.HashMap.clear_loop T self.slots 0#usize + Result.ret { self with num_entries := 0#usize, slots := v } /- [hashmap_main::hashmap::HashMap::{0}::len]: forward function -/ def hashmap.HashMap.len (T : Type) (self : hashmap.HashMap T) : Result Usize := @@ -130,27 +131,32 @@ def hashmap.HashMap.insert_no_resize := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod let inserted ← hashmap.HashMap.insert_in_list T key value l if inserted then do - let i0 ← self.num_entries + (Usize.ofInt 1) + let i0 ← self.num_entries + 1#usize let l0 ← hashmap.HashMap.insert_in_list_back T key value l - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } else do let l0 ← hashmap.HashMap.insert_in_list_back T key value l - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) self.slots hash_mod l0 Result.ret { self with slots := v } -/- [core::num::u32::{8}::MAX] -/ -def core_num_u32_max_body : Result U32 := Result.ret (U32.ofInt 4294967295) -def core_num_u32_max_c : U32 := eval_global core_num_u32_max_body (by simp) - /- [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.move_elements_from_list_loop @@ -175,29 +181,35 @@ def hashmap.HashMap.move_elements_from_list /- [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.move_elements_loop - (T : Type) (ntable : hashmap.HashMap T) (slots : Vec (hashmap.List T)) - (i : Usize) : - Result ((hashmap.HashMap T) × (Vec (hashmap.List T))) + (T : Type) (ntable : hashmap.HashMap T) + (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : + Result ((hashmap.HashMap T) × (alloc.vec.Vec (hashmap.List T))) := - let i0 := Vec.len (hashmap.List T) slots + let i0 := alloc.vec.Vec.len (hashmap.List T) slots if i < i0 then do - let l ← Vec.index_mut (hashmap.List T) slots i - let ls := mem.replace (hashmap.List T) l hashmap.List.Nil + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) slots i + let ls := core.mem.replace (hashmap.List T) l hashmap.List.Nil let ntable0 ← hashmap.HashMap.move_elements_from_list T ntable ls - let i1 ← i + (Usize.ofInt 1) - let l0 := mem.replace_back (hashmap.List T) l hashmap.List.Nil - let slots0 ← Vec.index_mut_back (hashmap.List T) slots i l0 + let i1 ← i + 1#usize + let l0 := core.mem.replace_back (hashmap.List T) l hashmap.List.Nil + let slots0 ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) slots i l0 hashmap.HashMap.move_elements_loop T ntable0 slots0 i1 else Result.ret (ntable, slots) /- [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def hashmap.HashMap.move_elements - (T : Type) (ntable : hashmap.HashMap T) (slots : Vec (hashmap.List T)) - (i : Usize) : - Result ((hashmap.HashMap T) × (Vec (hashmap.List T))) + (T : Type) (ntable : hashmap.HashMap T) + (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : + Result ((hashmap.HashMap T) × (alloc.vec.Vec (hashmap.List T))) := hashmap.HashMap.move_elements_loop T ntable slots i @@ -206,18 +218,18 @@ def hashmap.HashMap.move_elements def hashmap.HashMap.try_resize (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := do - let max_usize ← Scalar.cast .Usize core_num_u32_max_c - let capacity := Vec.len (hashmap.List T) self.slots - let n1 ← max_usize / (Usize.ofInt 2) + let max_usize ← Scalar.cast .Usize core_u32_max + let capacity := alloc.vec.Vec.len (hashmap.List T) self.slots + let n1 ← max_usize / 2#usize let (i, i0) := self.max_load_factor let i1 ← n1 / i if capacity <= i1 then do - let i2 ← capacity * (Usize.ofInt 2) + let i2 ← capacity * 2#usize let ntable ← hashmap.HashMap.new_with_capacity T i2 i i0 let (ntable0, _) ← - hashmap.HashMap.move_elements T ntable self.slots (Usize.ofInt 0) + hashmap.HashMap.move_elements T ntable self.slots 0#usize Result.ret { ntable0 @@ -259,9 +271,12 @@ def hashmap.HashMap.contains_key (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result Bool := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_shared (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod hashmap.HashMap.contains_key_in_list T key l /- [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function -/ @@ -284,9 +299,12 @@ def hashmap.HashMap.get (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result T := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_shared (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod hashmap.HashMap.get_in_list T key l /- [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function -/ @@ -331,9 +349,12 @@ def hashmap.HashMap.get_mut (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result T := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod hashmap.HashMap.get_mut_in_list T l key /- [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 -/ @@ -343,11 +364,17 @@ def hashmap.HashMap.get_mut_back := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod let l0 ← hashmap.HashMap.get_mut_in_list_back T l key ret0 - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } /- [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function -/ @@ -358,13 +385,13 @@ divergent def hashmap.HashMap.remove_from_list_loop if ckey = key then let mv_ls := - mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) + core.mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) hashmap.List.Nil match mv_ls with - | hashmap.List.Cons i cvalue tl0 => Result.ret (Option.some cvalue) + | hashmap.List.Cons i cvalue tl0 => Result.ret (some cvalue) | hashmap.List.Nil => Result.fail Error.panic else hashmap.HashMap.remove_from_list_loop T key tl - | hashmap.List.Nil => Result.ret Option.none + | hashmap.List.Nil => Result.ret none /- [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function -/ def hashmap.HashMap.remove_from_list @@ -379,7 +406,7 @@ divergent def hashmap.HashMap.remove_from_list_loop_back if ckey = key then let mv_ls := - mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) + core.mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) hashmap.List.Nil match mv_ls with | hashmap.List.Cons i cvalue tl0 => Result.ret tl0 @@ -400,16 +427,18 @@ def hashmap.HashMap.remove (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result (Option T) := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod let x ← hashmap.HashMap.remove_from_list T key l match x with - | Option.none => Result.ret Option.none - | Option.some x0 => - do - let _ ← self.num_entries - (Usize.ofInt 1) - Result.ret (Option.some x0) + | none => Result.ret none + | some x0 => do + let _ ← self.num_entries - 1#usize + Result.ret (some x0) /- [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 -/ def hashmap.HashMap.remove_back @@ -418,75 +447,75 @@ def hashmap.HashMap.remove_back := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod let x ← hashmap.HashMap.remove_from_list T key l match x with - | Option.none => + | none => do let l0 ← hashmap.HashMap.remove_from_list_back T key l - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) self.slots hash_mod l0 Result.ret { self with slots := v } - | Option.some x0 => + | some x0 => do - let i0 ← self.num_entries - (Usize.ofInt 1) + let i0 ← self.num_entries - 1#usize let l0 ← hashmap.HashMap.remove_from_list_back T key l - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } /- [hashmap_main::hashmap::test1]: forward function -/ def hashmap.test1 : Result Unit := do let hm ← hashmap.HashMap.new U64 - let hm0 ← hashmap.HashMap.insert U64 hm (Usize.ofInt 0) (U64.ofInt 42) - let hm1 ← hashmap.HashMap.insert U64 hm0 (Usize.ofInt 128) (U64.ofInt 18) - let hm2 ← - hashmap.HashMap.insert U64 hm1 (Usize.ofInt 1024) (U64.ofInt 138) - let hm3 ← - hashmap.HashMap.insert U64 hm2 (Usize.ofInt 1056) (U64.ofInt 256) - let i ← hashmap.HashMap.get U64 hm3 (Usize.ofInt 128) - if not (i = (U64.ofInt 18)) + let hm0 ← hashmap.HashMap.insert U64 hm 0#usize 42#u64 + let hm1 ← hashmap.HashMap.insert U64 hm0 128#usize 18#u64 + let hm2 ← hashmap.HashMap.insert U64 hm1 1024#usize 138#u64 + let hm3 ← hashmap.HashMap.insert U64 hm2 1056#usize 256#u64 + let i ← hashmap.HashMap.get U64 hm3 128#usize + if not (i = 18#u64) then Result.fail Error.panic else do - let hm4 ← - hashmap.HashMap.get_mut_back U64 hm3 (Usize.ofInt 1024) - (U64.ofInt 56) - let i0 ← hashmap.HashMap.get U64 hm4 (Usize.ofInt 1024) - if not (i0 = (U64.ofInt 56)) + let hm4 ← hashmap.HashMap.get_mut_back U64 hm3 1024#usize 56#u64 + let i0 ← hashmap.HashMap.get U64 hm4 1024#usize + if not (i0 = 56#u64) then Result.fail Error.panic else do - let x ← hashmap.HashMap.remove U64 hm4 (Usize.ofInt 1024) + let x ← hashmap.HashMap.remove U64 hm4 1024#usize match x with - | Option.none => Result.fail Error.panic - | Option.some x0 => - if not (x0 = (U64.ofInt 56)) + | none => Result.fail Error.panic + | some x0 => + if not (x0 = 56#u64) then Result.fail Error.panic else do - let hm5 ← - hashmap.HashMap.remove_back U64 hm4 (Usize.ofInt 1024) - let i1 ← hashmap.HashMap.get U64 hm5 (Usize.ofInt 0) - if not (i1 = (U64.ofInt 42)) + let hm5 ← hashmap.HashMap.remove_back U64 hm4 1024#usize + let i1 ← hashmap.HashMap.get U64 hm5 0#usize + if not (i1 = 42#u64) then Result.fail Error.panic else do - let i2 ← hashmap.HashMap.get U64 hm5 (Usize.ofInt 128) - if not (i2 = (U64.ofInt 18)) + let i2 ← hashmap.HashMap.get U64 hm5 128#usize + if not (i2 = 18#u64) then Result.fail Error.panic else do - let i3 ← - hashmap.HashMap.get U64 hm5 (Usize.ofInt 1056) - if not (i3 = (U64.ofInt 256)) + let i3 ← hashmap.HashMap.get U64 hm5 1056#usize + if not (i3 = 256#u64) then Result.fail Error.panic else Result.ret () -/- Unit test for [hashmap_main::hashmap::test1] -/ -#assert (hashmap.test1 == .ret ()) - /- [hashmap_main::insert_on_disk]: forward function -/ def insert_on_disk (key : Usize) (value : U64) (st : State) : Result (State × Unit) := @@ -500,7 +529,4 @@ def insert_on_disk def main : Result Unit := Result.ret () -/- Unit test for [hashmap_main::main] -/ -#assert (main == .ret ()) - end hashmap_main diff --git a/tests/lean/HashmapMain/Types.lean b/tests/lean/HashmapMain/Types.lean index 2b5cbd6c..065c109b 100644 --- a/tests/lean/HashmapMain/Types.lean +++ b/tests/lean/HashmapMain/Types.lean @@ -15,7 +15,7 @@ structure hashmap.HashMap (T : Type) where num_entries : Usize max_load_factor : (Usize × Usize) max_load : Usize - slots : Vec (hashmap.List T) + slots : alloc.vec.Vec (hashmap.List T) /- The state type used in the state-error monad -/ axiom State : Type diff --git a/tests/lean/Loops.lean b/tests/lean/Loops.lean index 60c73776..c6360338 100644 --- a/tests/lean/Loops.lean +++ b/tests/lean/Loops.lean @@ -1 +1,629 @@ -import Loops.Funs +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [loops] +import Base +open Primitives + +namespace loops + +/- [loops::sum]: loop 0: forward function -/ +divergent def sum_loop (max : U32) (i : U32) (s : U32) : Result U32 := + if i < max + then do + let s0 ← s + i + let i0 ← i + 1#u32 + sum_loop max i0 s0 + else s * 2#u32 + +/- [loops::sum]: forward function -/ +def sum (max : U32) : Result U32 := + sum_loop max 0#u32 0#u32 + +/- [loops::sum_with_mut_borrows]: loop 0: forward function -/ +divergent def sum_with_mut_borrows_loop + (max : U32) (mi : U32) (ms : U32) : Result U32 := + if mi < max + then + do + let ms0 ← ms + mi + let mi0 ← mi + 1#u32 + sum_with_mut_borrows_loop max mi0 ms0 + else ms * 2#u32 + +/- [loops::sum_with_mut_borrows]: forward function -/ +def sum_with_mut_borrows (max : U32) : Result U32 := + sum_with_mut_borrows_loop max 0#u32 0#u32 + +/- [loops::sum_with_shared_borrows]: loop 0: forward function -/ +divergent def sum_with_shared_borrows_loop + (max : U32) (i : U32) (s : U32) : Result U32 := + if i < max + then + do + let i0 ← i + 1#u32 + let s0 ← s + i0 + sum_with_shared_borrows_loop max i0 s0 + else s * 2#u32 + +/- [loops::sum_with_shared_borrows]: forward function -/ +def sum_with_shared_borrows (max : U32) : Result U32 := + sum_with_shared_borrows_loop max 0#u32 0#u32 + +/- [loops::clear]: loop 0: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +divergent def clear_loop + (v : alloc.vec.Vec U32) (i : Usize) : Result (alloc.vec.Vec U32) := + let i0 := alloc.vec.Vec.len U32 v + if i < i0 + then + do + let i1 ← i + 1#usize + let v0 ← + alloc.vec.Vec.index_mut_back U32 Usize + (core.slice.index.usize.coresliceindexSliceIndexInst U32) v i 0#u32 + clear_loop v0 i1 + else Result.ret v + +/- [loops::clear]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def clear (v : alloc.vec.Vec U32) : Result (alloc.vec.Vec U32) := + clear_loop v 0#usize + +/- [loops::List] -/ +inductive List (T : Type) := +| Cons : T → List T → List T +| Nil : List T + +/- [loops::list_mem]: loop 0: forward function -/ +divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := + match ls with + | List.Cons y tl => if y = x + then Result.ret true + else list_mem_loop x tl + | List.Nil => Result.ret false + +/- [loops::list_mem]: forward function -/ +def list_mem (x : U32) (ls : List U32) : Result Bool := + list_mem_loop x ls + +/- [loops::list_nth_mut_loop]: loop 0: forward function -/ +divergent def list_nth_mut_loop_loop + (T : Type) (ls : List T) (i : U32) : Result T := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret x + else do + let i0 ← i - 1#u32 + list_nth_mut_loop_loop T tl i0 + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop]: forward function -/ +def list_nth_mut_loop (T : Type) (ls : List T) (i : U32) : Result T := + list_nth_mut_loop_loop T ls i + +/- [loops::list_nth_mut_loop]: loop 0: backward function 0 -/ +divergent def list_nth_mut_loop_loop_back + (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl) + else + do + let i0 ← i - 1#u32 + let tl0 ← list_nth_mut_loop_loop_back T tl i0 ret0 + Result.ret (List.Cons x tl0) + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop]: backward function 0 -/ +def list_nth_mut_loop_back + (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := + list_nth_mut_loop_loop_back T ls i ret0 + +/- [loops::list_nth_shared_loop]: loop 0: forward function -/ +divergent def list_nth_shared_loop_loop + (T : Type) (ls : List T) (i : U32) : Result T := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret x + else do + let i0 ← i - 1#u32 + list_nth_shared_loop_loop T tl i0 + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_loop]: forward function -/ +def list_nth_shared_loop (T : Type) (ls : List T) (i : U32) : Result T := + list_nth_shared_loop_loop T ls i + +/- [loops::get_elem_mut]: loop 0: forward function -/ +divergent def get_elem_mut_loop (x : Usize) (ls : List Usize) : Result Usize := + match ls with + | List.Cons y tl => if y = x + then Result.ret y + else get_elem_mut_loop x tl + | List.Nil => Result.fail Error.panic + +/- [loops::get_elem_mut]: forward function -/ +def get_elem_mut + (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := + do + let l ← + alloc.vec.Vec.index_mut (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize + get_elem_mut_loop x l + +/- [loops::get_elem_mut]: loop 0: backward function 0 -/ +divergent def get_elem_mut_loop_back + (x : Usize) (ls : List Usize) (ret0 : Usize) : Result (List Usize) := + match ls with + | List.Cons y tl => + if y = x + then Result.ret (List.Cons ret0 tl) + else + do + let tl0 ← get_elem_mut_loop_back x tl ret0 + Result.ret (List.Cons y tl0) + | List.Nil => Result.fail Error.panic + +/- [loops::get_elem_mut]: backward function 0 -/ +def get_elem_mut_back + (slots : alloc.vec.Vec (List Usize)) (x : Usize) (ret0 : Usize) : + Result (alloc.vec.Vec (List Usize)) + := + do + let l ← + alloc.vec.Vec.index_mut (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize + let l0 ← get_elem_mut_loop_back x l ret0 + alloc.vec.Vec.index_mut_back (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) slots + 0#usize l0 + +/- [loops::get_elem_shared]: loop 0: forward function -/ +divergent def get_elem_shared_loop + (x : Usize) (ls : List Usize) : Result Usize := + match ls with + | List.Cons y tl => if y = x + then Result.ret y + else get_elem_shared_loop x tl + | List.Nil => Result.fail Error.panic + +/- [loops::get_elem_shared]: forward function -/ +def get_elem_shared + (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := + do + let l ← + alloc.vec.Vec.index (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize + get_elem_shared_loop x l + +/- [loops::id_mut]: forward function -/ +def id_mut (T : Type) (ls : List T) : Result (List T) := + Result.ret ls + +/- [loops::id_mut]: backward function 0 -/ +def id_mut_back (T : Type) (ls : List T) (ret0 : List T) : Result (List T) := + Result.ret ret0 + +/- [loops::id_shared]: forward function -/ +def id_shared (T : Type) (ls : List T) : Result (List T) := + Result.ret ls + +/- [loops::list_nth_mut_loop_with_id]: loop 0: forward function -/ +divergent def list_nth_mut_loop_with_id_loop + (T : Type) (i : U32) (ls : List T) : Result T := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret x + else do + let i0 ← i - 1#u32 + list_nth_mut_loop_with_id_loop T i0 tl + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_with_id]: forward function -/ +def list_nth_mut_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := + do + let ls0 ← id_mut T ls + list_nth_mut_loop_with_id_loop T i ls0 + +/- [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 -/ +divergent def list_nth_mut_loop_with_id_loop_back + (T : Type) (i : U32) (ls : List T) (ret0 : T) : Result (List T) := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl) + else + do + let i0 ← i - 1#u32 + let tl0 ← list_nth_mut_loop_with_id_loop_back T i0 tl ret0 + Result.ret (List.Cons x tl0) + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_with_id]: backward function 0 -/ +def list_nth_mut_loop_with_id_back + (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := + do + let ls0 ← id_mut T ls + let l ← list_nth_mut_loop_with_id_loop_back T i ls0 ret0 + id_mut_back T ls l + +/- [loops::list_nth_shared_loop_with_id]: loop 0: forward function -/ +divergent def list_nth_shared_loop_with_id_loop + (T : Type) (i : U32) (ls : List T) : Result T := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret x + else do + let i0 ← i - 1#u32 + list_nth_shared_loop_with_id_loop T i0 tl + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_loop_with_id]: forward function -/ +def list_nth_shared_loop_with_id + (T : Type) (ls : List T) (i : U32) : Result T := + do + let ls0 ← id_shared T ls + list_nth_shared_loop_with_id_loop T i ls0 + +/- [loops::list_nth_mut_loop_pair]: loop 0: forward function -/ +divergent def list_nth_mut_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else do + let i0 ← i - 1#u32 + list_nth_mut_loop_pair_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair]: forward function -/ +def list_nth_mut_loop_pair + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_mut_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 -/ +divergent def list_nth_mut_loop_pair_loop_back'a + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl0) + else + do + let i0 ← i - 1#u32 + let tl00 ← list_nth_mut_loop_pair_loop_back'a T tl0 tl1 i0 ret0 + Result.ret (List.Cons x0 tl00) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair]: backward function 0 -/ +def list_nth_mut_loop_pair_back'a + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_mut_loop_pair_loop_back'a T ls0 ls1 i ret0 + +/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 -/ +divergent def list_nth_mut_loop_pair_loop_back'b + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl1) + else + do + let i0 ← i - 1#u32 + let tl10 ← list_nth_mut_loop_pair_loop_back'b T tl0 tl1 i0 ret0 + Result.ret (List.Cons x1 tl10) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair]: backward function 1 -/ +def list_nth_mut_loop_pair_back'b + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_mut_loop_pair_loop_back'b T ls0 ls1 i ret0 + +/- [loops::list_nth_shared_loop_pair]: loop 0: forward function -/ +divergent def list_nth_shared_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else do + let i0 ← i - 1#u32 + list_nth_shared_loop_pair_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_loop_pair]: forward function -/ +def list_nth_shared_loop_pair + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_shared_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function -/ +divergent def list_nth_mut_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_mut_loop_pair_merge_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair_merge]: forward function -/ +def list_nth_mut_loop_pair_merge + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_mut_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 -/ +divergent def list_nth_mut_loop_pair_merge_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : + Result ((List T) × (List T)) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then let (t, t0) := ret0 + Result.ret (List.Cons t tl0, List.Cons t0 tl1) + else + do + let i0 ← i - 1#u32 + let (tl00, tl10) ← + list_nth_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x0 tl00, List.Cons x1 tl10) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair_merge]: backward function 0 -/ +def list_nth_mut_loop_pair_merge_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : + Result ((List T) × (List T)) + := + list_nth_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 + +/- [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function -/ +divergent def list_nth_shared_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_shared_loop_pair_merge_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_loop_pair_merge]: forward function -/ +def list_nth_shared_loop_pair_merge + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_shared_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function -/ +divergent def list_nth_mut_shared_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_mut_shared_loop_pair_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_shared_loop_pair]: forward function -/ +def list_nth_mut_shared_loop_pair + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_mut_shared_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 -/ +divergent def list_nth_mut_shared_loop_pair_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl0) + else + do + let i0 ← i - 1#u32 + let tl00 ← + list_nth_mut_shared_loop_pair_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x0 tl00) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_shared_loop_pair]: backward function 0 -/ +def list_nth_mut_shared_loop_pair_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_mut_shared_loop_pair_loop_back T ls0 ls1 i ret0 + +/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function -/ +divergent def list_nth_mut_shared_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_mut_shared_loop_pair_merge_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_shared_loop_pair_merge]: forward function -/ +def list_nth_mut_shared_loop_pair_merge + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_mut_shared_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 -/ +divergent def list_nth_mut_shared_loop_pair_merge_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl0) + else + do + let i0 ← i - 1#u32 + let tl00 ← + list_nth_mut_shared_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x0 tl00) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 -/ +def list_nth_mut_shared_loop_pair_merge_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_mut_shared_loop_pair_merge_loop_back T ls0 ls1 i ret0 + +/- [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function -/ +divergent def list_nth_shared_mut_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_shared_mut_loop_pair_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_mut_loop_pair]: forward function -/ +def list_nth_shared_mut_loop_pair + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_shared_mut_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 -/ +divergent def list_nth_shared_mut_loop_pair_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl1) + else + do + let i0 ← i - 1#u32 + let tl10 ← + list_nth_shared_mut_loop_pair_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x1 tl10) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_mut_loop_pair]: backward function 1 -/ +def list_nth_shared_mut_loop_pair_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_shared_mut_loop_pair_loop_back T ls0 ls1 i ret0 + +/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function -/ +divergent def list_nth_shared_mut_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_shared_mut_loop_pair_merge_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_mut_loop_pair_merge]: forward function -/ +def list_nth_shared_mut_loop_pair_merge + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_shared_mut_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 -/ +divergent def list_nth_shared_mut_loop_pair_merge_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl1) + else + do + let i0 ← i - 1#u32 + let tl10 ← + list_nth_shared_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x1 tl10) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 -/ +def list_nth_shared_mut_loop_pair_merge_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_shared_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 + +end loops diff --git a/tests/lean/Loops/Funs.lean b/tests/lean/Loops/Funs.lean deleted file mode 100644 index 5fbe200f..00000000 --- a/tests/lean/Loops/Funs.lean +++ /dev/null @@ -1,612 +0,0 @@ --- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS --- [loops]: function definitions -import Base -import Loops.Types -open Primitives - -namespace loops - -/- [loops::sum]: loop 0: forward function -/ -divergent def sum_loop (max : U32) (i : U32) (s : U32) : Result U32 := - if i < max - then do - let s0 ← s + i - let i0 ← i + (U32.ofInt 1) - sum_loop max i0 s0 - else s * (U32.ofInt 2) - -/- [loops::sum]: forward function -/ -def sum (max : U32) : Result U32 := - sum_loop max (U32.ofInt 0) (U32.ofInt 0) - -/- [loops::sum_with_mut_borrows]: loop 0: forward function -/ -divergent def sum_with_mut_borrows_loop - (max : U32) (mi : U32) (ms : U32) : Result U32 := - if mi < max - then - do - let ms0 ← ms + mi - let mi0 ← mi + (U32.ofInt 1) - sum_with_mut_borrows_loop max mi0 ms0 - else ms * (U32.ofInt 2) - -/- [loops::sum_with_mut_borrows]: forward function -/ -def sum_with_mut_borrows (max : U32) : Result U32 := - sum_with_mut_borrows_loop max (U32.ofInt 0) (U32.ofInt 0) - -/- [loops::sum_with_shared_borrows]: loop 0: forward function -/ -divergent def sum_with_shared_borrows_loop - (max : U32) (i : U32) (s : U32) : Result U32 := - if i < max - then - do - let i0 ← i + (U32.ofInt 1) - let s0 ← s + i0 - sum_with_shared_borrows_loop max i0 s0 - else s * (U32.ofInt 2) - -/- [loops::sum_with_shared_borrows]: forward function -/ -def sum_with_shared_borrows (max : U32) : Result U32 := - sum_with_shared_borrows_loop max (U32.ofInt 0) (U32.ofInt 0) - -/- [loops::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ -divergent def clear_loop (v : Vec U32) (i : Usize) : Result (Vec U32) := - let i0 := Vec.len U32 v - if i < i0 - then - do - let i1 ← i + (Usize.ofInt 1) - let v0 ← Vec.index_mut_back U32 v i (U32.ofInt 0) - clear_loop v0 i1 - else Result.ret v - -/- [loops::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ -def clear (v : Vec U32) : Result (Vec U32) := - clear_loop v (Usize.ofInt 0) - -/- [loops::list_mem]: loop 0: forward function -/ -divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := - match ls with - | List.Cons y tl => if y = x - then Result.ret true - else list_mem_loop x tl - | List.Nil => Result.ret false - -/- [loops::list_mem]: forward function -/ -def list_mem (x : U32) (ls : List U32) : Result Bool := - list_mem_loop x ls - -/- [loops::list_nth_mut_loop]: loop 0: forward function -/ -divergent def list_nth_mut_loop_loop - (T : Type) (ls : List T) (i : U32) : Result T := - match ls with - | List.Cons x tl => - if i = (U32.ofInt 0) - then Result.ret x - else do - let i0 ← i - (U32.ofInt 1) - list_nth_mut_loop_loop T tl i0 - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop]: forward function -/ -def list_nth_mut_loop (T : Type) (ls : List T) (i : U32) : Result T := - list_nth_mut_loop_loop T ls i - -/- [loops::list_nth_mut_loop]: loop 0: backward function 0 -/ -divergent def list_nth_mut_loop_loop_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := - match ls with - | List.Cons x tl => - if i = (U32.ofInt 0) - then Result.ret (List.Cons ret0 tl) - else - do - let i0 ← i - (U32.ofInt 1) - let tl0 ← list_nth_mut_loop_loop_back T tl i0 ret0 - Result.ret (List.Cons x tl0) - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop]: backward function 0 -/ -def list_nth_mut_loop_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := - list_nth_mut_loop_loop_back T ls i ret0 - -/- [loops::list_nth_shared_loop]: loop 0: forward function -/ -divergent def list_nth_shared_loop_loop - (T : Type) (ls : List T) (i : U32) : Result T := - match ls with - | List.Cons x tl => - if i = (U32.ofInt 0) - then Result.ret x - else do - let i0 ← i - (U32.ofInt 1) - list_nth_shared_loop_loop T tl i0 - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_loop]: forward function -/ -def list_nth_shared_loop (T : Type) (ls : List T) (i : U32) : Result T := - list_nth_shared_loop_loop T ls i - -/- [loops::get_elem_mut]: loop 0: forward function -/ -divergent def get_elem_mut_loop (x : Usize) (ls : List Usize) : Result Usize := - match ls with - | List.Cons y tl => if y = x - then Result.ret y - else get_elem_mut_loop x tl - | List.Nil => Result.fail Error.panic - -/- [loops::get_elem_mut]: forward function -/ -def get_elem_mut (slots : Vec (List Usize)) (x : Usize) : Result Usize := - do - let l ← Vec.index_mut (List Usize) slots (Usize.ofInt 0) - get_elem_mut_loop x l - -/- [loops::get_elem_mut]: loop 0: backward function 0 -/ -divergent def get_elem_mut_loop_back - (x : Usize) (ls : List Usize) (ret0 : Usize) : Result (List Usize) := - match ls with - | List.Cons y tl => - if y = x - then Result.ret (List.Cons ret0 tl) - else - do - let tl0 ← get_elem_mut_loop_back x tl ret0 - Result.ret (List.Cons y tl0) - | List.Nil => Result.fail Error.panic - -/- [loops::get_elem_mut]: backward function 0 -/ -def get_elem_mut_back - (slots : Vec (List Usize)) (x : Usize) (ret0 : Usize) : - Result (Vec (List Usize)) - := - do - let l ← Vec.index_mut (List Usize) slots (Usize.ofInt 0) - let l0 ← get_elem_mut_loop_back x l ret0 - Vec.index_mut_back (List Usize) slots (Usize.ofInt 0) l0 - -/- [loops::get_elem_shared]: loop 0: forward function -/ -divergent def get_elem_shared_loop - (x : Usize) (ls : List Usize) : Result Usize := - match ls with - | List.Cons y tl => if y = x - then Result.ret y - else get_elem_shared_loop x tl - | List.Nil => Result.fail Error.panic - -/- [loops::get_elem_shared]: forward function -/ -def get_elem_shared (slots : Vec (List Usize)) (x : Usize) : Result Usize := - do - let l ← Vec.index_shared (List Usize) slots (Usize.ofInt 0) - get_elem_shared_loop x l - -/- [loops::id_mut]: forward function -/ -def id_mut (T : Type) (ls : List T) : Result (List T) := - Result.ret ls - -/- [loops::id_mut]: backward function 0 -/ -def id_mut_back (T : Type) (ls : List T) (ret0 : List T) : Result (List T) := - Result.ret ret0 - -/- [loops::id_shared]: forward function -/ -def id_shared (T : Type) (ls : List T) : Result (List T) := - Result.ret ls - -/- [loops::list_nth_mut_loop_with_id]: loop 0: forward function -/ -divergent def list_nth_mut_loop_with_id_loop - (T : Type) (i : U32) (ls : List T) : Result T := - match ls with - | List.Cons x tl => - if i = (U32.ofInt 0) - then Result.ret x - else do - let i0 ← i - (U32.ofInt 1) - list_nth_mut_loop_with_id_loop T i0 tl - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_with_id]: forward function -/ -def list_nth_mut_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := - do - let ls0 ← id_mut T ls - list_nth_mut_loop_with_id_loop T i ls0 - -/- [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 -/ -divergent def list_nth_mut_loop_with_id_loop_back - (T : Type) (i : U32) (ls : List T) (ret0 : T) : Result (List T) := - match ls with - | List.Cons x tl => - if i = (U32.ofInt 0) - then Result.ret (List.Cons ret0 tl) - else - do - let i0 ← i - (U32.ofInt 1) - let tl0 ← list_nth_mut_loop_with_id_loop_back T i0 tl ret0 - Result.ret (List.Cons x tl0) - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_with_id]: backward function 0 -/ -def list_nth_mut_loop_with_id_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := - do - let ls0 ← id_mut T ls - let l ← list_nth_mut_loop_with_id_loop_back T i ls0 ret0 - id_mut_back T ls l - -/- [loops::list_nth_shared_loop_with_id]: loop 0: forward function -/ -divergent def list_nth_shared_loop_with_id_loop - (T : Type) (i : U32) (ls : List T) : Result T := - match ls with - | List.Cons x tl => - if i = (U32.ofInt 0) - then Result.ret x - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_shared_loop_with_id_loop T i0 tl - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_loop_with_id]: forward function -/ -def list_nth_shared_loop_with_id - (T : Type) (ls : List T) (i : U32) : Result T := - do - let ls0 ← id_shared T ls - list_nth_shared_loop_with_id_loop T i ls0 - -/- [loops::list_nth_mut_loop_pair]: loop 0: forward function -/ -divergent def list_nth_mut_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_mut_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair]: forward function -/ -def list_nth_mut_loop_pair - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_mut_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 -/ -divergent def list_nth_mut_loop_pair_loop_back'a - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (List.Cons ret0 tl0) - else - do - let i0 ← i - (U32.ofInt 1) - let tl00 ← list_nth_mut_loop_pair_loop_back'a T tl0 tl1 i0 ret0 - Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair]: backward function 0 -/ -def list_nth_mut_loop_pair_back'a - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_mut_loop_pair_loop_back'a T ls0 ls1 i ret0 - -/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 -/ -divergent def list_nth_mut_loop_pair_loop_back'b - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (List.Cons ret0 tl1) - else - do - let i0 ← i - (U32.ofInt 1) - let tl10 ← list_nth_mut_loop_pair_loop_back'b T tl0 tl1 i0 ret0 - Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair]: backward function 1 -/ -def list_nth_mut_loop_pair_back'b - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_mut_loop_pair_loop_back'b T ls0 ls1 i ret0 - -/- [loops::list_nth_shared_loop_pair]: loop 0: forward function -/ -divergent def list_nth_shared_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_shared_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_loop_pair]: forward function -/ -def list_nth_shared_loop_pair - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_shared_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function -/ -divergent def list_nth_mut_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_mut_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair_merge]: forward function -/ -def list_nth_mut_loop_pair_merge - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_mut_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 -/ -divergent def list_nth_mut_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : - Result ((List T) × (List T)) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then let (t, t0) := ret0 - Result.ret (List.Cons t tl0, List.Cons t0 tl1) - else - do - let i0 ← i - (U32.ofInt 1) - let (tl00, tl10) ← - list_nth_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x0 tl00, List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair_merge]: backward function 0 -/ -def list_nth_mut_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : - Result ((List T) × (List T)) - := - list_nth_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 - -/- [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function -/ -divergent def list_nth_shared_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_shared_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_loop_pair_merge]: forward function -/ -def list_nth_shared_loop_pair_merge - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_shared_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function -/ -divergent def list_nth_mut_shared_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_mut_shared_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_shared_loop_pair]: forward function -/ -def list_nth_mut_shared_loop_pair - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_mut_shared_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 -/ -divergent def list_nth_mut_shared_loop_pair_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (List.Cons ret0 tl0) - else - do - let i0 ← i - (U32.ofInt 1) - let tl00 ← - list_nth_mut_shared_loop_pair_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_shared_loop_pair]: backward function 0 -/ -def list_nth_mut_shared_loop_pair_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_mut_shared_loop_pair_loop_back T ls0 ls1 i ret0 - -/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function -/ -divergent def list_nth_mut_shared_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_mut_shared_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_shared_loop_pair_merge]: forward function -/ -def list_nth_mut_shared_loop_pair_merge - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_mut_shared_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 -/ -divergent def list_nth_mut_shared_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (List.Cons ret0 tl0) - else - do - let i0 ← i - (U32.ofInt 1) - let tl00 ← - list_nth_mut_shared_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 -/ -def list_nth_mut_shared_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_mut_shared_loop_pair_merge_loop_back T ls0 ls1 i ret0 - -/- [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function -/ -divergent def list_nth_shared_mut_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_shared_mut_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_mut_loop_pair]: forward function -/ -def list_nth_shared_mut_loop_pair - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_shared_mut_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 -/ -divergent def list_nth_shared_mut_loop_pair_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (List.Cons ret0 tl1) - else - do - let i0 ← i - (U32.ofInt 1) - let tl10 ← - list_nth_shared_mut_loop_pair_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_mut_loop_pair]: backward function 1 -/ -def list_nth_shared_mut_loop_pair_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_shared_mut_loop_pair_loop_back T ls0 ls1 i ret0 - -/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function -/ -divergent def list_nth_shared_mut_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_shared_mut_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_mut_loop_pair_merge]: forward function -/ -def list_nth_shared_mut_loop_pair_merge - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_shared_mut_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 -/ -divergent def list_nth_shared_mut_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = (U32.ofInt 0) - then Result.ret (List.Cons ret0 tl1) - else - do - let i0 ← i - (U32.ofInt 1) - let tl10 ← - list_nth_shared_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 -/ -def list_nth_shared_mut_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_shared_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 - -end loops diff --git a/tests/lean/Loops/Types.lean b/tests/lean/Loops/Types.lean deleted file mode 100644 index 018af901..00000000 --- a/tests/lean/Loops/Types.lean +++ /dev/null @@ -1,13 +0,0 @@ --- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS --- [loops]: type definitions -import Base -open Primitives - -namespace loops - -/- [loops::List] -/ -inductive List (T : Type) := -| Cons : T → List T → List T -| Nil : List T - -end loops diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index 884e62c4..c4a6a265 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -54,12 +54,24 @@ def div_test (x : U32) (y : U32) : Result U32 := /- [no_nested_borrows::div_test1]: forward function -/ def div_test1 (x : U32) : Result U32 := - x / (U32.ofInt 2) + x / 2#u32 /- [no_nested_borrows::rem_test]: forward function -/ def rem_test (x : U32) (y : U32) : Result U32 := x % y +/- [no_nested_borrows::mul_test]: forward function -/ +def mul_test (x : U32) (y : U32) : Result U32 := + x * y + +/- [no_nested_borrows::CONST0] -/ +def const0_body : Result Usize := 1#usize + 1#usize +def const0_c : Usize := eval_global const0_body (by simp) + +/- [no_nested_borrows::CONST1] -/ +def const1_body : Result Usize := 2#usize * 2#usize +def const1_c : Usize := eval_global const1_body (by simp) + /- [no_nested_borrows::cast_test]: forward function -/ def cast_test (x : U32) : Result I32 := Scalar.cast .I32 x @@ -67,7 +79,7 @@ def cast_test (x : U32) : Result I32 := /- [no_nested_borrows::test2]: forward function -/ def test2 : Result Unit := do - let _ ← (U32.ofInt 23) + (U32.ofInt 44) + let _ ← 23#u32 + 44#u32 Result.ret () /- Unit test for [no_nested_borrows::test2] -/ @@ -82,10 +94,10 @@ def get_max (x : U32) (y : U32) : Result U32 := /- [no_nested_borrows::test3]: forward function -/ def test3 : Result Unit := do - let x ← get_max (U32.ofInt 4) (U32.ofInt 3) - let y ← get_max (U32.ofInt 10) (U32.ofInt 11) + let x ← get_max 4#u32 3#u32 + let y ← get_max 10#u32 11#u32 let z ← x + y - if not (z = (U32.ofInt 15)) + if not (z = 15#u32) then Result.fail Error.panic else Result.ret () @@ -95,8 +107,8 @@ def test3 : Result Unit := /- [no_nested_borrows::test_neg1]: forward function -/ def test_neg1 : Result Unit := do - let y ← - (I32.ofInt 3) - if not (y = (I32.ofInt (-(3:Int)))) + let y ← - 3#i32 + if not (y = (-(3:Int))#i32) then Result.fail Error.panic else Result.ret () @@ -105,7 +117,7 @@ def test_neg1 : Result Unit := /- [no_nested_borrows::refs_test1]: forward function -/ def refs_test1 : Result Unit := - if not ((I32.ofInt 1) = (I32.ofInt 1)) + if not (1#i32 = 1#i32) then Result.fail Error.panic else Result.ret () @@ -114,16 +126,16 @@ def refs_test1 : Result Unit := /- [no_nested_borrows::refs_test2]: forward function -/ def refs_test2 : Result Unit := - if not ((I32.ofInt 2) = (I32.ofInt 2)) + if not (2#i32 = 2#i32) then Result.fail Error.panic else - if not ((I32.ofInt 0) = (I32.ofInt 0)) + if not (0#i32 = 0#i32) then Result.fail Error.panic else - if not ((I32.ofInt 2) = (I32.ofInt 2)) + if not (2#i32 = 2#i32) then Result.fail Error.panic else - if not ((I32.ofInt 2) = (I32.ofInt 2)) + if not (2#i32 = 2#i32) then Result.fail Error.panic else Result.ret () @@ -139,9 +151,9 @@ def test_list1 : Result Unit := /- [no_nested_borrows::test_box1]: forward function -/ def test_box1 : Result Unit := - let b := (I32.ofInt 1) + let b := 1#i32 let x := b - if not (x = (I32.ofInt 1)) + if not (x = 1#i32) then Result.fail Error.panic else Result.ret () @@ -167,8 +179,8 @@ def test_panic (b : Bool) : Result Unit := /- [no_nested_borrows::test_copy_int]: forward function -/ def test_copy_int : Result Unit := do - let y ← copy_int (I32.ofInt 0) - if not ((I32.ofInt 0) = y) + let y ← copy_int 0#i32 + if not (0#i32 = y) then Result.fail Error.panic else Result.ret () @@ -185,7 +197,7 @@ def is_cons (T : Type) (l : List T) : Result Bool := def test_is_cons : Result Unit := do let l := List.Nil - let b ← is_cons I32 (List.Cons (I32.ofInt 0) l) + let b ← is_cons I32 (List.Cons 0#i32 l) if not b then Result.fail Error.panic else Result.ret () @@ -203,9 +215,9 @@ def split_list (T : Type) (l : List T) : Result (T × (List T)) := def test_split_list : Result Unit := do let l := List.Nil - let p ← split_list I32 (List.Cons (I32.ofInt 0) l) + let p ← split_list I32 (List.Cons 0#i32 l) let (hd, _) := p - if not (hd = (I32.ofInt 0)) + if not (hd = 0#i32) then Result.fail Error.panic else Result.ret () @@ -228,19 +240,18 @@ def choose_back /- [no_nested_borrows::choose_test]: forward function -/ def choose_test : Result Unit := do - let z ← choose I32 true (I32.ofInt 0) (I32.ofInt 0) - let z0 ← z + (I32.ofInt 1) - if not (z0 = (I32.ofInt 1)) + let z ← choose I32 true 0#i32 0#i32 + let z0 ← z + 1#i32 + if not (z0 = 1#i32) then Result.fail Error.panic else do - let (x, y) ← choose_back I32 true (I32.ofInt 0) (I32.ofInt 0) z0 - if not (x = (I32.ofInt 1)) + let (x, y) ← choose_back I32 true 0#i32 0#i32 z0 + if not (x = 1#i32) then Result.fail Error.panic - else - if not (y = (I32.ofInt 0)) - then Result.fail Error.panic - else Result.ret () + else if not (y = 0#i32) + then Result.fail Error.panic + else Result.ret () /- Unit test for [no_nested_borrows::choose_test] -/ #assert (choose_test == .ret ()) @@ -268,17 +279,17 @@ divergent def list_length (T : Type) (l : List T) : Result U32 := match l with | List.Cons t l1 => do let i ← list_length T l1 - (U32.ofInt 1) + i - | List.Nil => Result.ret (U32.ofInt 0) + 1#u32 + i + | List.Nil => Result.ret 0#u32 /- [no_nested_borrows::list_nth_shared]: forward function -/ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_shared T tl i0 | List.Nil => Result.fail Error.panic @@ -286,10 +297,10 @@ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut T tl i0 | List.Nil => Result.fail Error.panic @@ -298,11 +309,11 @@ divergent def list_nth_mut_back (T : Type) (l : List T) (i : U32) (ret0 : T) : Result (List T) := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl0 ← list_nth_mut_back T tl i0 ret0 Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic @@ -317,54 +328,49 @@ divergent def list_rev_aux /- [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def list_rev (T : Type) (l : List T) : Result (List T) := - let li := mem.replace (List T) l List.Nil + let li := core.mem.replace (List T) l List.Nil list_rev_aux T li List.Nil /- [no_nested_borrows::test_list_functions]: forward function -/ def test_list_functions : Result Unit := do let l := List.Nil - let l0 := List.Cons (I32.ofInt 2) l - let l1 := List.Cons (I32.ofInt 1) l0 - let i ← list_length I32 (List.Cons (I32.ofInt 0) l1) - if not (i = (U32.ofInt 3)) + let l0 := List.Cons 2#i32 l + let l1 := List.Cons 1#i32 l0 + let i ← list_length I32 (List.Cons 0#i32 l1) + if not (i = 3#u32) then Result.fail Error.panic else do - let i0 ← - list_nth_shared I32 (List.Cons (I32.ofInt 0) l1) (U32.ofInt 0) - if not (i0 = (I32.ofInt 0)) + let i0 ← list_nth_shared I32 (List.Cons 0#i32 l1) 0#u32 + if not (i0 = 0#i32) then Result.fail Error.panic else do - let i1 ← - list_nth_shared I32 (List.Cons (I32.ofInt 0) l1) (U32.ofInt 1) - if not (i1 = (I32.ofInt 1)) + let i1 ← list_nth_shared I32 (List.Cons 0#i32 l1) 1#u32 + if not (i1 = 1#i32) then Result.fail Error.panic else do - let i2 ← - list_nth_shared I32 (List.Cons (I32.ofInt 0) l1) - (U32.ofInt 2) - if not (i2 = (I32.ofInt 2)) + let i2 ← list_nth_shared I32 (List.Cons 0#i32 l1) 2#u32 + if not (i2 = 2#i32) then Result.fail Error.panic else do let ls ← - list_nth_mut_back I32 (List.Cons (I32.ofInt 0) l1) - (U32.ofInt 1) (I32.ofInt 3) - let i3 ← list_nth_shared I32 ls (U32.ofInt 0) - if not (i3 = (I32.ofInt 0)) + list_nth_mut_back I32 (List.Cons 0#i32 l1) 1#u32 3#i32 + let i3 ← list_nth_shared I32 ls 0#u32 + if not (i3 = 0#i32) then Result.fail Error.panic else do - let i4 ← list_nth_shared I32 ls (U32.ofInt 1) - if not (i4 = (I32.ofInt 3)) + let i4 ← list_nth_shared I32 ls 1#u32 + if not (i4 = 3#i32) then Result.fail Error.panic else do - let i5 ← list_nth_shared I32 ls (U32.ofInt 2) - if not (i5 = (I32.ofInt 2)) + let i5 ← list_nth_shared I32 ls 2#u32 + if not (i5 = 2#i32) then Result.fail Error.panic else Result.ret () @@ -427,15 +433,15 @@ structure StructWithTuple (T1 T2 : Type) where /- [no_nested_borrows::new_tuple1]: forward function -/ def new_tuple1 : Result (StructWithTuple U32 U32) := - Result.ret { p := ((U32.ofInt 1), (U32.ofInt 2)) } + Result.ret { p := (1#u32, 2#u32) } /- [no_nested_borrows::new_tuple2]: forward function -/ def new_tuple2 : Result (StructWithTuple I16 I16) := - Result.ret { p := ((I16.ofInt 1), (I16.ofInt 2)) } + Result.ret { p := (1#i16, 2#i16) } /- [no_nested_borrows::new_tuple3]: forward function -/ def new_tuple3 : Result (StructWithTuple U64 I64) := - Result.ret { p := ((U64.ofInt 1), (I64.ofInt 2)) } + Result.ret { p := (1#u64, 2#i64) } /- [no_nested_borrows::StructWithPair] -/ structure StructWithPair (T1 T2 : Type) where @@ -443,31 +449,31 @@ structure StructWithPair (T1 T2 : Type) where /- [no_nested_borrows::new_pair1]: forward function -/ def new_pair1 : Result (StructWithPair U32 U32) := - Result.ret { p := { x := (U32.ofInt 1), y := (U32.ofInt 2) } } + Result.ret { p := { x := 1#u32, y := 2#u32 } } /- [no_nested_borrows::test_constants]: forward function -/ def test_constants : Result Unit := do let swt ← new_tuple1 let (i, _) := swt.p - if not (i = (U32.ofInt 1)) + if not (i = 1#u32) then Result.fail Error.panic else do let swt0 ← new_tuple2 let (i0, _) := swt0.p - if not (i0 = (I16.ofInt 1)) + if not (i0 = 1#i16) then Result.fail Error.panic else do let swt1 ← new_tuple3 let (i1, _) := swt1.p - if not (i1 = (U64.ofInt 1)) + if not (i1 = 1#u64) then Result.fail Error.panic else do let swp ← new_pair1 - if not (swp.p.x = (U32.ofInt 1)) + if not (swp.p.x = 1#u32) then Result.fail Error.panic else Result.ret () @@ -484,29 +490,29 @@ def test_weird_borrows1 : Result Unit := /- [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def test_mem_replace (px : U32) : Result U32 := - let y := mem.replace U32 px (U32.ofInt 1) - if not (y = (U32.ofInt 0)) + let y := core.mem.replace U32 px 1#u32 + if not (y = 0#u32) then Result.fail Error.panic - else Result.ret (U32.ofInt 2) + else Result.ret 2#u32 /- [no_nested_borrows::test_shared_borrow_bool1]: forward function -/ def test_shared_borrow_bool1 (b : Bool) : Result U32 := if b - then Result.ret (U32.ofInt 0) - else Result.ret (U32.ofInt 1) + then Result.ret 0#u32 + else Result.ret 1#u32 /- [no_nested_borrows::test_shared_borrow_bool2]: forward function -/ def test_shared_borrow_bool2 : Result U32 := - Result.ret (U32.ofInt 0) + Result.ret 0#u32 /- [no_nested_borrows::test_shared_borrow_enum1]: forward function -/ def test_shared_borrow_enum1 (l : List U32) : Result U32 := match l with - | List.Cons i l0 => Result.ret (U32.ofInt 1) - | List.Nil => Result.ret (U32.ofInt 0) + | List.Cons i l0 => Result.ret 1#u32 + | List.Nil => Result.ret 0#u32 /- [no_nested_borrows::test_shared_borrow_enum2]: forward function -/ def test_shared_borrow_enum2 : Result U32 := - Result.ret (U32.ofInt 0) + Result.ret 0#u32 end no_nested_borrows diff --git a/tests/lean/Paper.lean b/tests/lean/Paper.lean index c15c5e4b..ae4dd243 100644 --- a/tests/lean/Paper.lean +++ b/tests/lean/Paper.lean @@ -8,13 +8,13 @@ namespace paper /- [paper::ref_incr]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def ref_incr (x : I32) : Result I32 := - x + (I32.ofInt 1) + x + 1#i32 /- [paper::test_incr]: forward function -/ def test_incr : Result Unit := do - let x ← ref_incr (I32.ofInt 0) - if not (x = (I32.ofInt 1)) + let x ← ref_incr 0#i32 + if not (x = 1#i32) then Result.fail Error.panic else Result.ret () @@ -37,19 +37,18 @@ def choose_back /- [paper::test_choose]: forward function -/ def test_choose : Result Unit := do - let z ← choose I32 true (I32.ofInt 0) (I32.ofInt 0) - let z0 ← z + (I32.ofInt 1) - if not (z0 = (I32.ofInt 1)) + let z ← choose I32 true 0#i32 0#i32 + let z0 ← z + 1#i32 + if not (z0 = 1#i32) then Result.fail Error.panic else do - let (x, y) ← choose_back I32 true (I32.ofInt 0) (I32.ofInt 0) z0 - if not (x = (I32.ofInt 1)) + let (x, y) ← choose_back I32 true 0#i32 0#i32 z0 + if not (x = 1#i32) then Result.fail Error.panic - else - if not (y = (I32.ofInt 0)) - then Result.fail Error.panic - else Result.ret () + else if not (y = 0#i32) + then Result.fail Error.panic + else Result.ret () /- Unit test for [paper::test_choose] -/ #assert (test_choose == .ret ()) @@ -63,10 +62,10 @@ inductive List (T : Type) := divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut T tl i0 | List.Nil => Result.fail Error.panic @@ -75,11 +74,11 @@ divergent def list_nth_mut_back (T : Type) (l : List T) (i : U32) (ret0 : T) : Result (List T) := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl0 ← list_nth_mut_back T tl i0 ret0 Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic @@ -90,20 +89,19 @@ divergent def sum (l : List I32) : Result I32 := | List.Cons x tl => do let i ← sum tl x + i - | List.Nil => Result.ret (I32.ofInt 0) + | List.Nil => Result.ret 0#i32 /- [paper::test_nth]: forward function -/ def test_nth : Result Unit := do let l := List.Nil - let l0 := List.Cons (I32.ofInt 3) l - let l1 := List.Cons (I32.ofInt 2) l0 - let x ← list_nth_mut I32 (List.Cons (I32.ofInt 1) l1) (U32.ofInt 2) - let x0 ← x + (I32.ofInt 1) - let l2 ← - list_nth_mut_back I32 (List.Cons (I32.ofInt 1) l1) (U32.ofInt 2) x0 + let l0 := List.Cons 3#i32 l + let l1 := List.Cons 2#i32 l0 + let x ← list_nth_mut I32 (List.Cons 1#i32 l1) 2#u32 + let x0 ← x + 1#i32 + let l2 ← list_nth_mut_back I32 (List.Cons 1#i32 l1) 2#u32 x0 let i ← sum l2 - if not (i = (I32.ofInt 7)) + if not (i = 7#i32) then Result.fail Error.panic else Result.ret () @@ -115,7 +113,7 @@ def call_choose (p : (U32 × U32)) : Result U32 := do let (px, py) := p let pz ← choose U32 true px py - let pz0 ← pz + (U32.ofInt 1) + let pz0 ← pz + 1#u32 let (px0, _) ← choose_back U32 true px py pz0 Result.ret px0 diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean new file mode 100644 index 00000000..12e7eafa --- /dev/null +++ b/tests/lean/Traits.lean @@ -0,0 +1,383 @@ +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [traits] +import Base +open Primitives + +namespace traits + +/- Trait declaration: [traits::BoolTrait] -/ +structure BoolTrait (Self : Type) where + get_bool : Self → Result Bool + +/- [traits::Bool::{0}::get_bool]: forward function -/ +def Bool.get_bool (self : Bool) : Result Bool := + Result.ret self + +/- Trait implementation: [traits::Bool::{0}] -/ +def Bool.BoolTraitInst : BoolTrait Bool := { + get_bool := Bool.get_bool +} + +/- [traits::BoolTrait::ret_true]: forward function -/ +def BoolTrait.ret_true + {Self : Type} (self_clause : BoolTrait Self) (self : Self) : Result Bool := + Result.ret true + +/- [traits::test_bool_trait_bool]: forward function -/ +def test_bool_trait_bool (x : Bool) : Result Bool := + do + let b ← Bool.get_bool x + if b + then BoolTrait.ret_true Bool.BoolTraitInst x + else Result.ret false + +/- [traits::Option::{1}::get_bool]: forward function -/ +def Option.get_bool (T : Type) (self : Option T) : Result Bool := + match self with + | none => Result.ret false + | some t => Result.ret true + +/- Trait implementation: [traits::Option::{1}] -/ +def Option.BoolTraitInst (T : Type) : BoolTrait (Option T) := { + get_bool := Option.get_bool T +} + +/- [traits::test_bool_trait_option]: forward function -/ +def test_bool_trait_option (T : Type) (x : Option T) : Result Bool := + do + let b ← Option.get_bool T x + if b + then BoolTrait.ret_true (Option.BoolTraitInst T) x + else Result.ret false + +/- [traits::test_bool_trait]: forward function -/ +def test_bool_trait (T : Type) (inst : BoolTrait T) (x : T) : Result Bool := + inst.get_bool x + +/- Trait declaration: [traits::ToU64] -/ +structure ToU64 (Self : Type) where + to_u64 : Self → Result U64 + +/- [traits::u64::{2}::to_u64]: forward function -/ +def u64.to_u64 (self : U64) : Result U64 := + Result.ret self + +/- Trait implementation: [traits::u64::{2}] -/ +def u64.ToU64Inst : ToU64 U64 := { + to_u64 := u64.to_u64 +} + +/- [traits::Tuple2::{3}::to_u64]: forward function -/ +def Tuple2.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := + do + let (t, t0) := self + let i ← inst.to_u64 t + let i0 ← inst.to_u64 t0 + i + i0 + +/- Trait implementation: [traits::Tuple2::{3}] -/ +def Tuple2.ToU64Inst (A : Type) (inst : ToU64 A) : ToU64 (A × A) := { + to_u64 := Tuple2.to_u64 A inst +} + +/- [traits::f]: forward function -/ +def f (T : Type) (inst : ToU64 T) (x : (T × T)) : Result U64 := + Tuple2.to_u64 T inst x + +/- [traits::g]: forward function -/ +def g (T : Type) (inst : ToU64 (T × T)) (x : (T × T)) : Result U64 := + inst.to_u64 x + +/- [traits::h0]: forward function -/ +def h0 (x : U64) : Result U64 := + u64.to_u64 x + +/- [traits::Wrapper] -/ +structure Wrapper (T : Type) where + x : T + +/- [traits::Wrapper::{4}::to_u64]: forward function -/ +def Wrapper.to_u64 + (T : Type) (inst : ToU64 T) (self : Wrapper T) : Result U64 := + inst.to_u64 self.x + +/- Trait implementation: [traits::Wrapper::{4}] -/ +def Wrapper.ToU64Inst (T : Type) (inst : ToU64 T) : ToU64 (Wrapper T) := { + to_u64 := Wrapper.to_u64 T inst +} + +/- [traits::h1]: forward function -/ +def h1 (x : Wrapper U64) : Result U64 := + Wrapper.to_u64 U64 u64.ToU64Inst x + +/- [traits::h2]: forward function -/ +def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := + Wrapper.to_u64 T inst x + +/- Trait declaration: [traits::ToType] -/ +structure ToType (Self T : Type) where + to_type : Self → Result T + +/- [traits::u64::{5}::to_type]: forward function -/ +def u64.to_type (self : U64) : Result Bool := + Result.ret (self > 0#u64) + +/- Trait implementation: [traits::u64::{5}] -/ +def u64.ToTypeInst : ToType U64 Bool := { + to_type := u64.to_type +} + +/- Trait declaration: [traits::OfType] -/ +structure OfType (Self : Type) where + of_type : forall (T : Type) (inst : ToType T Self), T → Result Self + +/- [traits::h3]: forward function -/ +def h3 + (T1 T2 : Type) (inst : OfType T1) (inst0 : ToType T2 T1) (y : T2) : + Result T1 + := + inst.of_type T2 inst0 y + +/- Trait declaration: [traits::OfTypeBis] -/ +structure OfTypeBis (Self T : Type) where + parent_clause_0 : ToType T Self + of_type : T → Result Self + +/- [traits::h4]: forward function -/ +def h4 + (T1 T2 : Type) (inst : OfTypeBis T1 T2) (inst0 : ToType T2 T1) (y : T2) : + Result T1 + := + inst.of_type y + +/- [traits::TestType] -/ +structure TestType (T : Type) where + _0 : T + +/- [traits::TestType::{6}::test::TestType1] -/ +structure TestType.test.TestType1 where + _0 : U64 + +/- Trait declaration: [traits::TestType::{6}::test::TestTrait] -/ +structure TestType.test.TestTrait (Self : Type) where + test : Self → Result Bool + +/- [traits::TestType::{6}::test::TestType1::{0}::test]: forward function -/ +def TestType.test.TestType1.test + (self : TestType.test.TestType1) : Result Bool := + Result.ret (self._0 > 1#u64) + +/- Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] -/ +def TestType.test.TestType1.TestTypetestTestTraitInst : TestType.test.TestTrait + TestType.test.TestType1 := { + test := TestType.test.TestType1.test +} + +/- [traits::TestType::{6}::test]: forward function -/ +def TestType.test + (T : Type) (inst : ToU64 T) (self : TestType T) (x : T) : Result Bool := + do + let x0 ← inst.to_u64 x + if x0 > 0#u64 + then TestType.test.TestType1.test { _0 := 0#u64 } + else Result.ret false + +/- [traits::BoolWrapper] -/ +structure BoolWrapper where + _0 : Bool + +/- [traits::BoolWrapper::{7}::to_type]: forward function -/ +def BoolWrapper.to_type + (T : Type) (inst : ToType Bool T) (self : BoolWrapper) : Result T := + inst.to_type self._0 + +/- Trait implementation: [traits::BoolWrapper::{7}] -/ +def BoolWrapper.ToTypeInst (T : Type) (inst : ToType Bool T) : ToType + BoolWrapper T := { + to_type := BoolWrapper.to_type T inst +} + +/- [traits::WithConstTy::LEN2] -/ +def with_const_ty_len2_body : Result Usize := Result.ret 32#usize +def with_const_ty_len2_c : Usize := + eval_global with_const_ty_len2_body (by simp) + +/- Trait declaration: [traits::WithConstTy] -/ +structure WithConstTy (Self : Type) (LEN : Usize) where + LEN1 : Usize + LEN2 : Usize + V : Type + W : Type + W_clause_0 : ToU64 W + f : W → Array U8 LEN → Result W + +/- [traits::Bool::{8}::LEN1] -/ +def bool_len1_body : Result Usize := Result.ret 12#usize +def bool_len1_c : Usize := eval_global bool_len1_body (by simp) + +/- [traits::Bool::{8}::f]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def Bool.f (i : U64) (a : Array U8 32#usize) : Result U64 := + Result.ret i + +/- Trait implementation: [traits::Bool::{8}] -/ +def Bool.WithConstTyInst : WithConstTy Bool 32#usize := { + LEN1 := bool_len1_c + LEN2 := with_const_ty_len2_c + V := U8 + W := U64 + W_clause_0 := u64.ToU64Inst + f := Bool.f +} + +/- [traits::use_with_const_ty1]: forward function -/ +def use_with_const_ty1 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) : Result Usize := + let i := inst.LEN1 + Result.ret i + +/- [traits::use_with_const_ty2]: forward function -/ +def use_with_const_ty2 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (w : inst.W) : + Result Unit + := + Result.ret () + +/- [traits::use_with_const_ty3]: forward function -/ +def use_with_const_ty3 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (x : inst.W) : + Result U64 + := + inst.W_clause_0.to_u64 x + +/- [traits::test_where1]: forward function -/ +def test_where1 (T : Type) (_x : T) : Result Unit := + Result.ret () + +/- [traits::test_where2]: forward function -/ +def test_where2 + (T : Type) (inst : WithConstTy T 32#usize) (_x : U32) : Result Unit := + Result.ret () + +/- [alloc::string::String] -/ +axiom alloc.string.String : Type + +/- Trait declaration: [traits::ParentTrait0] -/ +structure ParentTrait0 (Self : Type) where + W : Type + get_name : Self → Result alloc.string.String + get_w : Self → Result W + +/- Trait declaration: [traits::ParentTrait1] -/ +structure ParentTrait1 (Self : Type) where + +/- Trait declaration: [traits::ChildTrait] -/ +structure ChildTrait (Self : Type) where + parent_clause_0 : ParentTrait0 Self + parent_clause_1 : ParentTrait1 Self + +/- [traits::test_child_trait1]: forward function -/ +def test_child_trait1 + (T : Type) (inst : ChildTrait T) (x : T) : Result alloc.string.String := + inst.parent_clause_0.get_name x + +/- [traits::test_child_trait2]: forward function -/ +def test_child_trait2 + (T : Type) (inst : ChildTrait T) (x : T) : Result inst.parent_clause_0.W := + inst.parent_clause_0.get_w x + +/- [traits::order1]: forward function -/ +def order1 + (T U : Type) (inst : ParentTrait0 T) (inst0 : ParentTrait0 U) : + Result Unit + := + Result.ret () + +/- Trait declaration: [traits::ChildTrait1] -/ +structure ChildTrait1 (Self : Type) where + parent_clause_0 : ParentTrait1 Self + +/- Trait implementation: [traits::usize::{9}] -/ +def usize.ParentTrait1Inst : ParentTrait1 Usize := { +} + +/- Trait implementation: [traits::usize::{10}] -/ +def usize.ChildTrait1Inst : ChildTrait1 Usize := { + parent_clause_0 := usize.ParentTrait1Inst +} + +/- Trait declaration: [traits::Iterator] -/ +structure Iterator (Self : Type) where + Item : Type + +/- Trait declaration: [traits::IntoIterator] -/ +structure IntoIterator (Self : Type) where + Item : Type + IntoIter : Type + IntoIter_clause_0 : Iterator IntoIter + into_iter : Self → Result IntoIter + +/- Trait declaration: [traits::FromResidual] -/ +structure FromResidual (Self T : Type) where + +/- Trait declaration: [traits::Try] -/ +structure Try (Self : Type) where + Residual : Type + parent_clause_0 : FromResidual Self Residual + +/- Trait declaration: [traits::WithTarget] -/ +structure WithTarget (Self : Type) where + Target : Type + +/- Trait declaration: [traits::ParentTrait2] -/ +structure ParentTrait2 (Self : Type) where + U : Type + U_clause_0 : WithTarget U + +/- Trait declaration: [traits::ChildTrait2] -/ +structure ChildTrait2 (Self : Type) where + parent_clause_0 : ParentTrait2 Self + convert : parent_clause_0.U → Result parent_clause_0.U_clause_0.Target + +/- Trait implementation: [traits::u32::{11}] -/ +def u32.WithTargetInst : WithTarget U32 := { + Target := U32 +} + +/- Trait implementation: [traits::u32::{12}] -/ +def u32.ParentTrait2Inst : ParentTrait2 U32 := { + U := U32 + U_clause_0 := u32.WithTargetInst +} + +/- [traits::u32::{13}::convert]: forward function -/ +def u32.convert (x : U32) : Result U32 := + Result.ret x + +/- Trait implementation: [traits::u32::{13}] -/ +def u32.ChildTrait2Inst : ChildTrait2 U32 := { + parent_clause_0 := u32.ParentTrait2Inst + convert := u32.convert +} + +/- [traits::incr_u32]: forward function -/ +def incr_u32 (x : U32) : Result U32 := + x + 1#u32 + +/- Trait declaration: [traits::CFnOnce] -/ +structure CFnOnce (Self Args : Type) where + Output : Type + call_once : Self → Args → Result Output + +/- Trait declaration: [traits::CFnMut] -/ +structure CFnMut (Self Args : Type) where + parent_clause_0 : CFnOnce Self Args + call_mut : Self → Args → Result parent_clause_0.Output + call_mut_back : Self → Args → parent_clause_0.Output → Result Self + +/- Trait declaration: [traits::CFn] -/ +structure CFn (Self Args : Type) where + parent_clause_0 : CFnMut Self Args + call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output + +end traits diff --git a/tests/lean/lakefile.lean b/tests/lean/lakefile.lean index 8acf6973..fef94971 100644 --- a/tests/lean/lakefile.lean +++ b/tests/lean/lakefile.lean @@ -19,3 +19,4 @@ package «tests» {} @[default_target] lean_lib paper @[default_target] lean_lib poloniusList @[default_target] lean_lib array +@[default_target] lean_lib traits |