Repository: AeneasVerif/eurydice
Branch: main
Commit: 4e769f096186
Files: 346
Total size: 5.3 MB
Directory structure:
gitextract_fzr909fs/
├── .github/
│ └── workflows/
│ └── nix.yaml
├── .gitignore
├── .ocamlformat
├── .ocamlformat-ignore
├── LICENSE-APACHE
├── LICENSE-MIT
├── Makefile
├── README.md
├── bin/
│ ├── dune
│ └── main.ml
├── cremepat/
│ ├── Lex.ml
│ ├── Parse.mly
│ ├── ParseTree.ml
│ ├── README.md
│ ├── cremepat.ml
│ └── dune
├── dune
├── dune-project
├── eurydice.opam
├── flake.nix
├── include/
│ └── eurydice_glue.h
├── lib/
│ ├── AstOfLlbc.ml
│ ├── Builtin.ml
│ ├── Bundles.ml
│ ├── Cleanup1.ml
│ ├── Cleanup2.ml
│ ├── Cleanup3.ml
│ ├── LoadLlbc.ml
│ ├── Logging.ml
│ ├── Options.ml
│ ├── PreCleanup.ml
│ ├── Utf8.ml
│ └── dune
├── out/
│ ├── test-array/
│ │ ├── array.c
│ │ └── array.h
│ ├── test-array2d/
│ │ ├── array2d.c
│ │ └── array2d.h
│ ├── test-castunsize/
│ │ ├── castunsize.c
│ │ └── castunsize.h
│ ├── test-closure/
│ │ ├── closure.c
│ │ └── closure.h
│ ├── test-closure_fn_cast/
│ │ ├── closure_fn_cast.c
│ │ └── closure_fn_cast.h
│ ├── test-collision/
│ │ ├── collision.c
│ │ └── collision.h
│ ├── test-const_generics/
│ │ ├── const_generics.c
│ │ └── const_generics.h
│ ├── test-core_num/
│ │ ├── core_num.c
│ │ └── core_num.h
│ ├── test-dst/
│ │ ├── dst.c
│ │ └── dst.h
│ ├── test-dyn_trait_struct_type/
│ │ ├── dyn_trait_struct_type.c
│ │ └── dyn_trait_struct_type.h
│ ├── test-floating_points/
│ │ ├── floating_points.c
│ │ └── floating_points.h
│ ├── test-fn_cast/
│ │ ├── fn_cast.c
│ │ └── fn_cast.h
│ ├── test-fn_higher_order/
│ │ ├── fn_higher_order.c
│ │ └── fn_higher_order.h
│ ├── test-for/
│ │ ├── for.c
│ │ └── for.h
│ ├── test-global_ref/
│ │ ├── global_ref.c
│ │ └── global_ref.h
│ ├── test-i32_shl/
│ │ ├── i32_shl.c
│ │ └── i32_shl.h
│ ├── test-inline_attributes/
│ │ ├── inline_attributes.c
│ │ └── inline_attributes.h
│ ├── test-int_switch/
│ │ ├── int_switch.c
│ │ └── int_switch.h
│ ├── test-issue_102/
│ │ ├── issue_102.c
│ │ └── issue_102.h
│ ├── test-issue_104/
│ │ ├── issue_104.c
│ │ └── issue_104.h
│ ├── test-issue_105/
│ │ ├── issue_105.c
│ │ └── issue_105.h
│ ├── test-issue_106/
│ │ ├── issue_106.c
│ │ └── issue_106.h
│ ├── test-issue_107/
│ │ ├── issue_107.c
│ │ └── issue_107.h
│ ├── test-issue_123/
│ │ ├── issue_123.c
│ │ └── issue_123.h
│ ├── test-issue_128/
│ │ ├── issue_128.c
│ │ └── issue_128.h
│ ├── test-issue_212/
│ │ ├── issue_212.c
│ │ └── issue_212.h
│ ├── test-issue_37/
│ │ ├── issue_37.c
│ │ └── issue_37.h
│ ├── test-issue_49/
│ │ ├── issue_49.c
│ │ └── issue_49.h
│ ├── test-issue_96/
│ │ ├── issue_96.c
│ │ └── issue_96.h
│ ├── test-issue_k630/
│ │ ├── issue_k630.c
│ │ └── issue_k630.h
│ ├── test-issue_shift/
│ │ ├── issue_shift.c
│ │ └── issue_shift.h
│ ├── test-libcrux-ml-dsa/
│ │ ├── internal/
│ │ │ ├── libcrux_mldsa_avx2.h
│ │ │ ├── libcrux_mldsa_core.h
│ │ │ ├── libcrux_mldsa_portable.h
│ │ │ ├── libcrux_sha3_avx2.h
│ │ │ └── libcrux_sha3_internal.h
│ │ ├── libcrux_mldsa44_avx2.c
│ │ ├── libcrux_mldsa44_avx2.h
│ │ ├── libcrux_mldsa44_portable.c
│ │ ├── libcrux_mldsa44_portable.h
│ │ ├── libcrux_mldsa65_avx2.c
│ │ ├── libcrux_mldsa65_avx2.h
│ │ ├── libcrux_mldsa65_portable.c
│ │ ├── libcrux_mldsa65_portable.h
│ │ ├── libcrux_mldsa87_avx2.c
│ │ ├── libcrux_mldsa87_avx2.h
│ │ ├── libcrux_mldsa87_portable.c
│ │ ├── libcrux_mldsa87_portable.h
│ │ ├── libcrux_mldsa_avx2.c
│ │ ├── libcrux_mldsa_avx2.h
│ │ ├── libcrux_mldsa_core.c
│ │ ├── libcrux_mldsa_core.h
│ │ ├── libcrux_mldsa_portable.c
│ │ ├── libcrux_mldsa_portable.h
│ │ ├── libcrux_sha3.h
│ │ ├── libcrux_sha3_avx2.c
│ │ ├── libcrux_sha3_avx2.h
│ │ └── libcrux_sha3_internal.h
│ ├── test-libcrux-ml-kem/
│ │ ├── internal/
│ │ │ ├── libcrux_core.h
│ │ │ ├── libcrux_mlkem1024_avx2.h
│ │ │ ├── libcrux_mlkem1024_portable.h
│ │ │ ├── libcrux_mlkem512_avx2.h
│ │ │ ├── libcrux_mlkem512_portable.h
│ │ │ ├── libcrux_mlkem768_avx2.h
│ │ │ ├── libcrux_mlkem768_portable.h
│ │ │ ├── libcrux_mlkem_avx2.h
│ │ │ ├── libcrux_mlkem_portable.h
│ │ │ └── libcrux_sha3_internal.h
│ │ ├── libcrux_core.c
│ │ ├── libcrux_core.h
│ │ ├── libcrux_mlkem1024.h
│ │ ├── libcrux_mlkem1024_avx2.c
│ │ ├── libcrux_mlkem1024_avx2.h
│ │ ├── libcrux_mlkem1024_portable.c
│ │ ├── libcrux_mlkem1024_portable.h
│ │ ├── libcrux_mlkem512.h
│ │ ├── libcrux_mlkem512_avx2.c
│ │ ├── libcrux_mlkem512_avx2.h
│ │ ├── libcrux_mlkem512_portable.c
│ │ ├── libcrux_mlkem512_portable.h
│ │ ├── libcrux_mlkem768.h
│ │ ├── libcrux_mlkem768_avx2.c
│ │ ├── libcrux_mlkem768_avx2.h
│ │ ├── libcrux_mlkem768_portable.c
│ │ ├── libcrux_mlkem768_portable.h
│ │ ├── libcrux_mlkem_avx2.c
│ │ ├── libcrux_mlkem_avx2.h
│ │ ├── libcrux_mlkem_portable.c
│ │ ├── libcrux_mlkem_portable.h
│ │ ├── libcrux_sha3_avx2.c
│ │ ├── libcrux_sha3_avx2.h
│ │ ├── libcrux_sha3_internal.h
│ │ ├── libcrux_sha3_portable.c
│ │ └── libcrux_sha3_portable.h
│ ├── test-libcrux-ml-kem-no-const/
│ │ ├── internal/
│ │ │ ├── libcrux_core.h
│ │ │ ├── libcrux_mlkem1024_avx2.h
│ │ │ ├── libcrux_mlkem1024_portable.h
│ │ │ ├── libcrux_mlkem512_avx2.h
│ │ │ ├── libcrux_mlkem512_portable.h
│ │ │ ├── libcrux_mlkem768_avx2.h
│ │ │ ├── libcrux_mlkem768_portable.h
│ │ │ ├── libcrux_mlkem_avx2.h
│ │ │ ├── libcrux_mlkem_portable.h
│ │ │ └── libcrux_sha3_internal.h
│ │ ├── libcrux_core.c
│ │ ├── libcrux_core.h
│ │ ├── libcrux_mlkem1024.h
│ │ ├── libcrux_mlkem1024_avx2.c
│ │ ├── libcrux_mlkem1024_avx2.h
│ │ ├── libcrux_mlkem1024_portable.c
│ │ ├── libcrux_mlkem1024_portable.h
│ │ ├── libcrux_mlkem512.h
│ │ ├── libcrux_mlkem512_avx2.c
│ │ ├── libcrux_mlkem512_avx2.h
│ │ ├── libcrux_mlkem512_portable.c
│ │ ├── libcrux_mlkem512_portable.h
│ │ ├── libcrux_mlkem768.h
│ │ ├── libcrux_mlkem768_avx2.c
│ │ ├── libcrux_mlkem768_avx2.h
│ │ ├── libcrux_mlkem768_portable.c
│ │ ├── libcrux_mlkem768_portable.h
│ │ ├── libcrux_mlkem_avx2.c
│ │ ├── libcrux_mlkem_avx2.h
│ │ ├── libcrux_mlkem_portable.c
│ │ ├── libcrux_mlkem_portable.h
│ │ ├── libcrux_sha3_avx2.c
│ │ ├── libcrux_sha3_avx2.h
│ │ ├── libcrux_sha3_internal.h
│ │ ├── libcrux_sha3_portable.c
│ │ └── libcrux_sha3_portable.h
│ ├── test-lvalue/
│ │ ├── lvalue.c
│ │ └── lvalue.h
│ ├── test-mismatch/
│ │ ├── mismatch.c
│ │ └── mismatch.h
│ ├── test-more_dst/
│ │ ├── more_dst.c
│ │ └── more_dst.h
│ ├── test-more_primitive_types/
│ │ ├── more_primitive_types.c
│ │ └── more_primitive_types.h
│ ├── test-more_str/
│ │ ├── more_str.c
│ │ └── more_str.h
│ ├── test-names/
│ │ ├── names.c
│ │ └── names.h
│ ├── test-nested_arrays/
│ │ ├── nested_arrays.c
│ │ └── nested_arrays.h
│ ├── test-nested_arrays2/
│ │ ├── nested_arrays2.c
│ │ └── nested_arrays2.h
│ ├── test-option/
│ │ ├── option.c
│ │ └── option.h
│ ├── test-parentparent/
│ │ ├── parentparent.c
│ │ └── parentparent.h
│ ├── test-partial_eq/
│ │ ├── partial_eq.c
│ │ └── partial_eq.h
│ ├── test-raw_pointers/
│ │ ├── raw_pointers.c
│ │ └── raw_pointers.h
│ ├── test-reborrow/
│ │ ├── reborrow.c
│ │ └── reborrow.h
│ ├── test-recursion/
│ │ ├── recursion.c
│ │ └── recursion.h
│ ├── test-repeat/
│ │ ├── repeat.c
│ │ └── repeat.h
│ ├── test-result/
│ │ ├── result.c
│ │ └── result.h
│ ├── test-signed_wrapping/
│ │ ├── signed_wrapping.c
│ │ └── signed_wrapping.h
│ ├── test-slice_array/
│ │ ├── slice_array.c
│ │ └── slice_array.h
│ ├── test-step_by/
│ │ ├── step_by.c
│ │ └── step_by.h
│ ├── test-substr/
│ │ ├── substr.c
│ │ └── substr.h
│ ├── test-symcrust/
│ │ ├── internal/
│ │ │ └── Eurydice.h
│ │ ├── symcrust.c
│ │ └── symcrust.h
│ ├── test-trait_generics/
│ │ ├── trait_generics.c
│ │ └── trait_generics.h
│ ├── test-traits/
│ │ ├── traits.c
│ │ └── traits.h
│ ├── test-traits2/
│ │ ├── traits2.c
│ │ └── traits2.h
│ ├── test-traits3/
│ │ ├── traits3.c
│ │ └── traits3.h
│ ├── test-we_need_charon_monomorphization/
│ │ ├── we_need_charon_monomorphization.c
│ │ └── we_need_charon_monomorphization.h
│ ├── test-where_clauses_closures/
│ │ ├── where_clauses_closures.c
│ │ └── where_clauses_closures.h
│ ├── test-where_clauses_fncg/
│ │ ├── where_clauses_fncg.c
│ │ └── where_clauses_fncg.h
│ ├── test-where_clauses_simple/
│ │ ├── where_clauses_simple.c
│ │ └── where_clauses_simple.h
│ └── testxx-result/
│ ├── result.cc
│ └── result.h
├── scripts/
│ ├── check-dependency.sh
│ ├── ci-check-charon-pin-is-forward.sh
│ ├── ci-check-charon-pin-is-merged.sh
│ ├── format.sh
│ └── update-charon-pin.sh
└── test/
├── array.rs
├── array2d.rs
├── castunsize.rs
├── chunks.rs
├── closure.rs
├── closure_fn_cast.rs
├── collision.rs
├── const_generics.rs
├── core_cmp_lib.c
├── core_num.rs
├── core_str_lib.c
├── dst.rs
├── dyn_trait_struct_type.rs
├── floating_points.rs
├── fn_cast.rs
├── fn_higher_order.rs
├── for.rs
├── global_ref.rs
├── i32_shl.rs
├── inline_attributes.rs
├── int_switch.rs
├── issue_102.rs
├── issue_104.rs
├── issue_105.rs
├── issue_106.rs
├── issue_107.rs
├── issue_123.rs
├── issue_128.rs
├── issue_14.rs
├── issue_212.rs
├── issue_311.rs
├── issue_37.rs
├── issue_49.rs
├── issue_96.rs
├── issue_99.rs
├── issue_k630.rs
├── issue_shift.rs
├── libcrux-ml-dsa/
│ ├── CMakeLists.txt
│ ├── c.yaml
│ └── tests/
│ ├── mldsa65.cc
│ ├── nistkats-65.json
│ └── nistkats_pre_hashed-65.json
├── libcrux-ml-kem/
│ ├── CMakeLists.txt
│ ├── c.yaml
│ ├── intrinsics/
│ │ └── libcrux_intrinsics_avx2.h
│ └── tests/
│ ├── mlkem768.cc
│ ├── mlkem768_nistkats.json
│ └── sha3.cc
├── lvalue.rs
├── main.c
├── mismatch.rs
├── more_dst.rs
├── more_primitive_types.rs
├── more_primitive_types.yaml
├── more_str.rs
├── mutable_slice_range.rs
├── names.rs
├── nested_arrays.rs
├── nested_arrays2.rs
├── option.rs
├── parentparent.rs
├── partial_eq.rs
├── partial_eq_stubs.c
├── println.rs
├── raw_pointers.rs
├── reborrow.rs
├── recursion.rs
├── repeat.rs
├── result.rs
├── signed_wrapping.rs
├── slice_array.rs
├── step_by.rs
├── substr.rs
├── substr.yaml
├── substr_impl.c
├── substr_stubs.h
├── symcrust.rs
├── trait_generics.rs
├── traits.rs
├── traits2.rs
├── traits3.rs
├── we_need_charon_monomorphization.rs
├── where_clauses.rs
├── where_clauses_closures.rs
├── where_clauses_fncg.rs
└── where_clauses_simple.rs
================================================
FILE CONTENTS
================================================
================================================
FILE: .github/workflows/nix.yaml
================================================
name: Build Eurydice and run tests
on:
push:
branches:
- main
pull_request:
workflow_dispatch:
# Cancel previous versions of this job that are still running.
concurrency:
group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }}
cancel-in-progress: true
jobs:
check:
runs-on: self-hosted
steps:
- uses: actions/checkout@v3
- name: Build and test
run: nix flake check -L
charon-pin-is-forward:
runs-on: self-hosted
steps:
- uses: actions/checkout@v4
with:
fetch-depth: 0 # deep clone in order to get access to other commits
- run: nix develop '.#ci' --command ./scripts/ci-check-charon-pin-is-forward.sh
charon-pin-is-merged:
runs-on: self-hosted
steps:
- uses: actions/checkout@v4
with:
fetch-depth: 0 # deep clone in order to get access to other commits
- run: nix develop '.#ci' --command ./scripts/ci-check-charon-pin-is-merged.sh
================================================
FILE: .gitignore
================================================
/karamel
/charon
/libcrux
_build
test/*/target
out/*/a.out
*.DS_Store
*.orig
*.llbc
eurydice
/.vscode
.charon_version
test/libcrux-*/build
_opam
.cache
================================================
FILE: .ocamlformat
================================================
profile = default
version = 0.27.0
margin = 100
break-cases = fit-or-vertical
exp-grouping = preserve
if-then-else = vertical
parens-tuple = multi-line-only
parens-tuple-patterns = multi-line-only
================================================
FILE: .ocamlformat-ignore
================================================
lib/charon/**
lib/krml/**
================================================
FILE: LICENSE-APACHE
================================================
Apache License
Version 2.0, January 2004
http://www.apache.org/licenses/
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
1. Definitions.
"License" shall mean the terms and conditions for use, reproduction,
and distribution as defined by Sections 1 through 9 of this document.
"Licensor" shall mean the copyright owner or entity authorized by
the copyright owner that is granting the License.
"Legal Entity" shall mean the union of the acting entity and all
other entities that control, are controlled by, or are under common
control with that entity. For the purposes of this definition,
"control" means (i) the power, direct or indirect, to cause the
direction or management of such entity, whether by contract or
otherwise, or (ii) ownership of fifty percent (50%) or more of the
outstanding shares, or (iii) beneficial ownership of such entity.
"You" (or "Your") shall mean an individual or Legal Entity
exercising permissions granted by this License.
"Source" form shall mean the preferred form for making modifications,
including but not limited to software source code, documentation
source, and configuration files.
"Object" form shall mean any form resulting from mechanical
transformation or translation of a Source form, including but
not limited to compiled object code, generated documentation,
and conversions to other media types.
"Work" shall mean the work of authorship, whether in Source or
Object form, made available under the License, as indicated by a
copyright notice that is included in or attached to the work
(an example is provided in the Appendix below).
"Derivative Works" shall mean any work, whether in Source or Object
form, that is based on (or derived from) the Work and for which the
editorial revisions, annotations, elaborations, or other modifications
represent, as a whole, an original work of authorship. For the purposes
of this License, Derivative Works shall not include works that remain
separable from, or merely link (or bind by name) to the interfaces of,
the Work and Derivative Works thereof.
"Contribution" shall mean any work of authorship, including
the original version of the Work and any modifications or additions
to that Work or Derivative Works thereof, that is intentionally
submitted to Licensor for inclusion in the Work by the copyright owner
or by an individual or Legal Entity authorized to submit on behalf of
the copyright owner. For the purposes of this definition, "submitted"
means any form of electronic, verbal, or written communication sent
to the Licensor or its representatives, including but not limited to
communication on electronic mailing lists, source code control systems,
and issue tracking systems that are managed by, or on behalf of, the
Licensor for the purpose of discussing and improving the Work, but
excluding communication that is conspicuously marked or otherwise
designated in writing by the copyright owner as "Not a Contribution."
"Contributor" shall mean Licensor and any individual or Legal Entity
on behalf of whom a Contribution has been received by Licensor and
subsequently incorporated within the Work.
2. Grant of Copyright License. Subject to the terms and conditions of
this License, each Contributor hereby grants to You a perpetual,
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
copyright license to reproduce, prepare Derivative Works of,
publicly display, publicly perform, sublicense, and distribute the
Work and such Derivative Works in Source or Object form.
3. Grant of Patent License. Subject to the terms and conditions of
this License, each Contributor hereby grants to You a perpetual,
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
(except as stated in this section) patent license to make, have made,
use, offer to sell, sell, import, and otherwise transfer the Work,
where such license applies only to those patent claims licensable
by such Contributor that are necessarily infringed by their
Contribution(s) alone or by combination of their Contribution(s)
with the Work to which such Contribution(s) was submitted. If You
institute patent litigation against any entity (including a
cross-claim or counterclaim in a lawsuit) alleging that the Work
or a Contribution incorporated within the Work constitutes direct
or contributory patent infringement, then any patent licenses
granted to You under this License for that Work shall terminate
as of the date such litigation is filed.
4. Redistribution. You may reproduce and distribute copies of the
Work or Derivative Works thereof in any medium, with or without
modifications, and in Source or Object form, provided that You
meet the following conditions:
(a) You must give any other recipients of the Work or
Derivative Works a copy of this License; and
(b) You must cause any modified files to carry prominent notices
stating that You changed the files; and
(c) You must retain, in the Source form of any Derivative Works
that You distribute, all copyright, patent, trademark, and
attribution notices from the Source form of the Work,
excluding those notices that do not pertain to any part of
the Derivative Works; and
(d) If the Work includes a "NOTICE" text file as part of its
distribution, then any Derivative Works that You distribute must
include a readable copy of the attribution notices contained
within such NOTICE file, excluding those notices that do not
pertain to any part of the Derivative Works, in at least one
of the following places: within a NOTICE text file distributed
as part of the Derivative Works; within the Source form or
documentation, if provided along with the Derivative Works; or,
within a display generated by the Derivative Works, if and
wherever such third-party notices normally appear. The contents
of the NOTICE file are for informational purposes only and
do not modify the License. You may add Your own attribution
notices within Derivative Works that You distribute, alongside
or as an addendum to the NOTICE text from the Work, provided
that such additional attribution notices cannot be construed
as modifying the License.
You may add Your own copyright statement to Your modifications and
may provide additional or different license terms and conditions
for use, reproduction, or distribution of Your modifications, or
for any such Derivative Works as a whole, provided Your use,
reproduction, and distribution of the Work otherwise complies with
the conditions stated in this License.
5. Submission of Contributions. Unless You explicitly state otherwise,
any Contribution intentionally submitted for inclusion in the Work
by You to the Licensor shall be under the terms and conditions of
this License, without any additional terms or conditions.
Notwithstanding the above, nothing herein shall supersede or modify
the terms of any separate license agreement you may have executed
with Licensor regarding such Contributions.
6. Trademarks. This License does not grant permission to use the trade
names, trademarks, service marks, or product names of the Licensor,
except as required for reasonable and customary use in describing the
origin of the Work and reproducing the content of the NOTICE file.
7. Disclaimer of Warranty. Unless required by applicable law or
agreed to in writing, Licensor provides the Work (and each
Contributor provides its Contributions) on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied, including, without limitation, any warranties or conditions
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
PARTICULAR PURPOSE. You are solely responsible for determining the
appropriateness of using or redistributing the Work and assume any
risks associated with Your exercise of permissions under this License.
8. Limitation of Liability. In no event and under no legal theory,
whether in tort (including negligence), contract, or otherwise,
unless required by applicable law (such as deliberate and grossly
negligent acts) or agreed to in writing, shall any Contributor be
liable to You for damages, including any direct, indirect, special,
incidental, or consequential damages of any character arising as a
result of this License or out of the use or inability to use the
Work (including but not limited to damages for loss of goodwill,
work stoppage, computer failure or malfunction, or any and all
other commercial damages or losses), even if such Contributor
has been advised of the possibility of such damages.
9. Accepting Warranty or Additional Liability. While redistributing
the Work or Derivative Works thereof, You may choose to offer,
and charge a fee for, acceptance of support, warranty, indemnity,
or other liability obligations and/or rights consistent with this
License. However, in accepting such obligations, You may act only
on Your own behalf and on Your sole responsibility, not on behalf
of any other Contributor, and only if You agree to indemnify,
defend, and hold each Contributor harmless for any liability
incurred by, or claims asserted against, such Contributor by reason
of your accepting any such warranty or additional liability.
END OF TERMS AND CONDITIONS
APPENDIX: How to apply the Apache License to your work.
To apply the Apache License to your work, attach the following
boilerplate notice, with the fields enclosed by brackets "[]"
replaced with your own identifying information. (Don't include
the brackets!) The text should be enclosed in the appropriate
comment syntax for the file format. We also recommend that a
file or class name and description of purpose be included on the
same "printed page" as the copyright notice for easier
identification within third-party archives.
Copyright 2024 Eurydice Contributors
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
================================================
FILE: LICENSE-MIT
================================================
MIT License
Copyright (c) 2024 Eurydice Contributors
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
================================================
FILE: Makefile
================================================
CHARON_HOME ?= $(dir $(abspath $(lastword $(MAKEFILE_LIST))))/charon
KRML_HOME ?= $(dir $(abspath $(lastword $(MAKEFILE_LIST))))/karamel
LIBCRUX_HOME ?= $(dir $(abspath $(lastword $(MAKEFILE_LIST))))/libcrux
EURYDICE ?= ./eurydice $(EURYDICE_FLAGS)
CHARON ?= $(CHARON_HOME)/bin/charon
BROKEN_TESTS = where_clauses println chunks mutable_slice_range issue_99 issue_14 issue_311
TEST_DIRS = $(filter-out $(BROKEN_TESTS),$(basename $(notdir $(wildcard test/*.rs))))
# Warn on old versions of bash
_ := $(shell bash -c '(( $${BASH_VERSION%%.*} >= 4 ))')
ifneq ($(.SHELLSTATUS),0)
_: $(error "bash version is too old; hint: brew install bash")
endif
# Warn on old versions of make
ifeq (3.81,$(MAKE_VERSION))
$(error You seem to be using the OSX antiquated Make version. Hint: brew \
install make, then invoke gmake instead of make)
endif
# Enable `foo/**` glob syntax
SHELL := bash -O globstar
ifeq ($(shell uname -s),Darwin)
ifeq (,$(shell which gsed))
$(error gsed not found; try brew install gnu-sed)
endif
SED=gsed
else
SED=sed
endif
ifneq ($(shell $(CHARON) version), $(shell cat .charon_version &>/dev/null || true))
_ := $(shell $(CHARON) version > .charon_version)
endif
.PHONY: all
all: format-check
@ocamlfind list | grep -q charon || test -L lib/charon || echo "⚠️⚠️⚠️ Charon not found; we suggest run 'make setup-charon'"
@ocamlfind list | grep -q krml || test -L lib/krml || echo "⚠️⚠️⚠️ krml not found; we suggest run 'make setup-karamel'"
$(MAKE) build
.PHONY: build
build: check-karamel check-charon
dune build && ln -sf _build/default/bin/main.exe eurydice
CFLAGS := -Wall -Werror -Wno-unused-variable -Wno-unused-but-set-variable $(CFLAGS) -I$(KRML_HOME)/include
CXXFLAGS := -std=c++17
test: $(addprefix test-,$(TEST_DIRS)) custom-test-libcrux-ml-kem-no-const custom-test-array custom-test-for testxx-result check-charon check-libcrux test-libcrux-ml-kem
clean-and-test:
$(MAKE) clean-llbc
$(MAKE) test
.PRECIOUS: %.llbc
%.llbc: %.rs .charon_version
# --mir elaborated --add-drop-bounds
$(CHARON) rustc --preset=eurydice --dest-file "$@" $(CHARON_EXTRA) -- -Aunused $<
out/test-%/main.c: test/main.c
mkdir -p out/test-$*
sed 's/__NAME__/$*/g' $< > $@
test/issue_99.llbc: CHARON_EXTRA = \
--include=core::option::*::as_ref
test/issue_105.llbc: CHARON_EXTRA = \
--include=core::result::*::branch \
--include=core::result::*::from_residual \
--include=core::result::*::eq \
--include=core::cmp::* \
--include=core::convert::*
test/array2d.llbc: CHARON_EXTRA = --include=core::array::equality::*
test/core_num.llbc: CHARON_EXTRA = \
--include=core::num::*::BITS \
--include=core::num::*::MAX
test/println.llbc: CHARON_EXTRA = \
--include=core::fmt::Arguments --include=core::fmt::rt::*::new_const \
--include=core::fmt::rt::Argument
test/option.llbc: CHARON_EXTRA = \
--include=core::option::*
test/lvalue.llbc: CHARON_EXTRA = \
--mir elaborated
test-substr: EXTRA_C = -I../../test ../../test/substr_impl.c
test-substr: EXTRA = --config test/substr.yaml
test-partial_eq: EXTRA_C = ../../test/partial_eq_stubs.c
test-nested_arrays: EXTRA = -funroll-loops 0
test-array: EXTRA = -fcomments
test-symcrust: CFLAGS += -Wno-unused-function
test-more_str: EXTRA_C = ../../test/core_str_lib.c
test-more_primitive_types: EXTRA = --config test/more_primitive_types.yaml
test-global_ref: EXTRA_C = ../../test/core_cmp_lib.c
test-lvalue: CFLAGS += -Wno-unused-but-set-variable
test-issue_shift: CFLAGS += -fsanitize=undefined
test-%: test/%.llbc out/test-%/main.c | all
$(EURYDICE) $(EXTRA) --output out/test-$* $<
$(SED) -i 's/ KaRaMeL version: .*//' out/test-$*/**/*.{c,h} # This changes on every commit
$(SED) -i 's/ KaRaMeL invocation: .*//' out/test-$*/**/*.{c,h} # This changes between local and CI
cd out/test-$* && $(CC) $(CFLAGS) -I. -I../../include $(EXTRA_C) $*.c main.c && ./a.out
# C++ tests
out/testxx-%/main.cc: test/main.c
mkdir -p out/testxx-$*
sed 's/__NAME__/$*/g' $< > $@
testxx-%: test/%.llbc out/testxx-%/main.cc | all
$(EURYDICE) $(EXTRA) -fc++17-compat --output out/testxx-$* $<
$(SED) -i 's/ KaRaMeL version: .*//' out/testxx-$*/**/*.{c,h} # This changes on every commit
$(SED) -i 's/ KaRaMeL invocation: .*//' out/testxx-$*/**/*.{c,h} # This changes between local and CI
mv out/testxx-$*/$*.c out/testxx-$*/$*.cc
cd out/testxx-$* && $(CXX) $(CXXFLAGS) $(CFLAGS) -I. -I../../include $(EXTRA_C) $*.cc main.cc && ./a.out
custom-test-array: test-array
grep -q XXX1 out/test-array/array.c && \
grep -q XXX2 out/test-array/array.c && \
true
custom-test-for: test-for
! grep -q while out/test-for/for.c
# libcrux tests
custom-test-libcrux-ml-kem-no-const: test/libcrux-ml-kem.llbc
mkdir -p out/test-libcrux-ml-kem-no-const
$(EURYDICE) --config test/libcrux-ml-kem/c.yaml -funroll-loops 16 \
$< --keep-going --output out/test-libcrux-ml-kem-no-const --no-const
$(SED) -i 's/ KaRaMeL version: .*//' out/test-libcrux-ml-kem-no-const/**/*.{c,h} # This changes on every commit
$(SED) -i 's/ KaRaMeL invocation: .*//' out/test-libcrux-ml-kem-no-const/**/*.{c,h} # This changes between local and CI
test-libcrux-%: test/libcrux-%.llbc
mkdir -p out/test-libcrux-$*
$(EURYDICE) --config test/libcrux-$*/c.yaml -funroll-loops 16 \
$< --keep-going --output out/test-libcrux-$*
$(SED) -i 's/ KaRaMeL version: .*//' out/test-libcrux-$*/**/*.{c,h} # This changes on every commit
$(SED) -i 's/ KaRaMeL invocation: .*//' out/test-libcrux-$*/**/*.{c,h} # This changes between local and CI
cd test/libcrux-$*/ && cmake $(CMAKE_FLAGS) -B build -G "Ninja Multi-Config" && cmake --build build --config Debug
cd test/libcrux-$*/ && ./build/Debug/$(subst -,_,$*)_test
cd test/libcrux-$*/ && if [ -x ./build/Debug/sha3_test ]; then ./build/Debug/sha3_test; fi
.PHONY: .FORCE
test/libcrux-%.llbc: .FORCE
@# Use our committed `Cargo.lock` by default.
cp libcrux-Cargo.lock $(LIBCRUX_HOME)/Cargo.lock
RUSTFLAGS="-Cdebug-assertions=no --cfg eurydice" $(CHARON) cargo --preset eurydice \
--include 'libcrux_sha3' \
--include 'libcrux_secrets' \
--include=core::option::* \
--rustc-arg='-Aunused' \
--start-from libcrux_$(subst -,_,$*) --start-from libcrux_sha3 \
--include 'core::num::*::BITS' --include 'core::num::*::MAX' \
--dest-file $$PWD/$@ -- \
--manifest-path $(LIBCRUX_HOME)/libcrux-$*/Cargo.toml \
--target=x86_64-apple-darwin
@# Commit the `Cargo.lock` so that the nix CI can use it
cp $(LIBCRUX_HOME)/Cargo.lock libcrux-Cargo.lock
.PRECIOUS: out/%
out/%:
mkdir -p $@
.PHONY: check-dependencies
check-dependencies: check-karamel check-charon check-libcrux
# % can be "charon", "karamel" or "libcrux".
.PHONY: check-%
check-%:
@bash ./scripts/check-dependency.sh "$*"
.PHONY: setup-%
setup-%:
bash ./scripts/check-dependency.sh "$*" --force
.PHONY: nix-magic
nix-magic:
nix flake update karamel charon libcrux --extra-experimental-features nix-command --extra-experimental-features flakes
nix-update-%:
PROJECT_REMOTE=$(shell cd $* && git config --get remote.origin.url | cut -d ':' -f 2 | sed s/.git//g); \
PROJECT_REV=$(shell cd $* && git rev-parse head); \
nix flake update $* --override-input $* "github:$$PROJECT_REMOTE/$$PROJECT_REV"
# Updates `flake.lock` with the latest commit from our local charon clone (the one that is symlinked into `lib/charon`).
.PHONY: update-charon-pin
update-charon-pin:
nix-shell -p jq --run ./scripts/update-charon-pin.sh
FORMAT_FILE=include/eurydice_glue.h
.PHONY: format-check
format-check:
FORMAT_FILE=$(FORMAT_FILE) ./scripts/format.sh check
.PHONY: format-apply
format-apply:
FORMAT_FILE=$(FORMAT_FILE) ./scripts/format.sh apply
.PHONY: clean-llbc
clean-llbc:
rm test/*.llbc || true
debug-ppx-%: lib/%
dune describe pp $<
================================================
FILE: README.md
================================================
Nicolas Poussin, Orphée et Eurydice.
Musée du Louvre.
Source
# Eurydice
Eurydice is a compiler from Rust to C. The purpose of Eurydice is to provide a
backwards-compatibility story as the verification ecosystem gradually
transitions to Rust. New programs can be written in Rust, in turn making them
safer and easier to verify; but for legacy environments that cannot yet take a
dependency on the Rust toolchain, Eurydice allows generating C code as a stopgap
measure.
## Guarantee
Eurydice's informal guarantee is: if the Rust program terminates without
panicking, then the Eurydice-compiled C code computes the same result without
undefined behavior. If the Rust program panics (e.g., on signed integer
overflow, out-of-bounds array access), no guarantees are made about the behavior
of the generated C code.
Currently (late 2023), the flagship example for Eurydice is Kyber, a
Post-Quantum cryptographic algorithm authored and
verified in Rust for the general public, and [compiled to C via
Eurydice](https://github.com/cryspen/hacl-packages/tree/7a7bfbb17d1d912bdb1a80e86a917e1eec8b6264/libcrux/src)
for Mozilla's NSS library.
In terms of software architecture, Eurydice consumes Rust programs via the
[Charon](https://github.com/AeneasVerif/charon) infrastructure, then extracts
Rust to [KaRaMeL](https://github.com/FStarLang/karamel)'s internal AST via a
type-driven translation. Once in the KaRaMeL AST, 30+ nano-passes allow going
from Rust down to C code. About half of these passes were already implemented
for KaRaMeL, the rest of the passes reuse the KaRaMeL infrastructure but were
freshly written for Eurydice.
If you want to contribute or ask questions, we strongly encourage you to join
the [Zulip](https://aeneas-verif.zulipchat.com/).
# Install
We recommend using Nix to easily ensure you are running the right versions of the tools and
libraries. With nix, you can run:
```bash
$ nix run 'github:aeneasverif/eurydice#charon' -- [CHARON_OPTIONS]
$ nix run 'github:aeneasverif/eurydice' -- [EURYDICE_OPTIONS]
```
Alternatively, you can do a local setup as follows.
```bash
# Step 1: install OCaml environment. Follow instructions, reload your shell, and make sure
# `eval $(opam env)` has been suitably added to your shell profile.
sudo apt install opam cargo # or brew on OSX
opam init
# Step 2: clone eurydice
git clone https://github.com/AeneasVerif/eurydice
cd eurydice
# Step 3: install dependent projects
# This will clone karamel, charon and libcrux. If you intend to also develop on one of these
# projects, you can symlink your working copy (e.g. `ln -s ../my-charon charon`) instead.
# Note: the invocation for karamel might fail, in which case you want to install all the packages
# in the `depends` field of karamel.opam except fstar. At the time of writing, this means typing:
# opam install ocamlfind batteries zarith stdint yojson ocamlbuild fileutils menhir pprint ulex process fix visitors wasm ppx_deriving ppx_deriving_yojson uucp
make setup-karamel
make setup-charon
make setup-libcrux
# Step 4: ready!
make test
```
# Submitting a successful PR
The C output of the test suite is under version control, and your PR will fail CI if running `make
test` generates a diff for the C files in `out/`. The reason for this is that we need to assess the
impact of a PR on the shape of the generated C code. To make sure the output of the tests is
up-to-date, you can run `make -B test` to force regeneration of the C files.
Our CI will also check that your OCaml and C files have proper formatting -- the target `make
format-apply` reformats your source code to conform to our style guide. It might sometimes be
difficult to have the exact right versions of ocamlformat and clang-format -- in case your PR still
fails, we recommend running `nix develop` followed by `make format-apply`.
================================================
FILE: bin/dune
================================================
(executable
(public_name eurydice)
(name main)
(libraries eurydice terminal))
(env
(_
(flags
(:standard -w @1-2@3-7@8..12@14..21@23..29-30@31..38-39-40-41@43@57))))
================================================
FILE: bin/main.ml
================================================
let () =
let usage =
Printf.sprintf
{|Eurydice: from Rust to C
Usage: %s [OPTIONS] FILES
FILES are .llbc files produced by Charon. Eurydice will generate one C file per
llbc file.
Supported options:|}
Sys.argv.(0)
in
let module O = Eurydice.Options in
let debug s =
Krml.Options.debug_modules := Krml.KString.split_on_char ',' s @ !Krml.Options.debug_modules;
if List.mem "backtrace" !Krml.Options.debug_modules then
Krml.Options.backtrace := true
in
let funroll_loops = ref 16 in
let spec =
[
"--log", Arg.Set_string O.log_level, " log level, use * for everything";
"--debug", Arg.String debug, " debug options, to be passed to krml";
"--output", Arg.Set_string Krml.Options.tmpdir, " output directory in which to write files";
( "--header",
Arg.Set_string Krml.Options.header,
" path to a header file to be prepended to the generated C" );
"--config", Arg.Set_string O.config, " YAML configuration file";
( "--keep-going",
Arg.Set O.keep_going,
" keep going even though extracting some definitions might fail" );
"--no-const", Arg.Set O.no_const, " do not introduce the const keyword for pointers";
"-fcomments", Arg.Set O.comments, " keep inline comments";
"-funroll-loops", Arg.Set_int funroll_loops, " unrool loops up to N";
( "-fc++17-compat",
Arg.Set Krml.Options.cxx17_compat,
" instead of generating C11/C++20 code (default), generate C++17-only code" );
]
in
let spec = Arg.align spec in
let files = ref [] in
let fatal_error =
Printf.ksprintf (fun s ->
print_endline s;
exit 255)
in
let anon_fun f =
if Filename.check_suffix f ".llbc" then
files := f :: !files
else
fatal_error "Unknown file extension for %s" f
in
begin
try Arg.parse spec anon_fun usage
with e ->
Printf.printf "Error parsing command-line: %s\n%s\n" (Printexc.get_backtrace ())
(Printexc.to_string e);
fatal_error "Incorrect invocation, was: %s\n" (String.concat "␣" (Array.to_list Sys.argv))
end;
if !files = [] then
fatal_error "%s" (Arg.usage_string spec usage);
let terminal_width =
Terminal.Size.(
match get_dimensions () with
| Some d -> d.columns
| None -> 80)
in
let pfiles b files =
PPrint.(ToBuffer.pretty 0.95 terminal_width b (Krml.PrintAst.print_files files ^^ hardline))
in
let fail file line =
Printf.printf "%s:%d exiting\n" file line;
exit 1
in
(* This is where the action happens *)
Eurydice.Logging.enable_logging !O.log_level;
(* Type applications are compiled as a regular external type. *)
Krml.(
Options.(
allow_tapps := true;
minimal := true;
curly_braces := true;
add_very_early_include := [ All, "\"eurydice_glue.h\"" ];
parentheses := true;
no_shadow := true;
extern_c := true;
cxx_compat := true;
unroll_loops := !funroll_loops;
static_header :=
[
Bundle.Prefix [ "core"; "convert" ];
Bundle.Prefix [ "core"; "num" ];
Bundle.Prefix [ "Eurydice"; "Int128" ];
];
Warn.parse_warn_error (!warn_error ^ "+8"));
Monomorphization.NameGen.short_names := true;
Monomorphization.NameGen.distinguished := Eurydice.Cleanup3.distinguished_names;
AstToCStar.no_return_type_lids :=
[
[ "Eurydice" ], "slice_index_shared";
[ "Eurydice" ], "slice_index_mut";
[ "Eurydice" ], "slice_len";
[ "Eurydice" ], "slice_copy";
[ "Eurydice" ], "array_eq";
]);
(* Some logic for more precisely tracking readonly functions, so as to remove
excessive uu__ variables. *)
let readonly_lids = Hashtbl.create 41 in
let readonly_map = Hashtbl.create 41 in
let fill_readonly_table files =
List.iter
(fun (_, decls) ->
List.iter
(function
| Krml.Ast.DFunction (_, _, _, _, _, name, _, body) ->
Hashtbl.add readonly_map name body
| _ -> ())
decls)
files
in
Krml.(
Helpers.is_readonly_builtin_lid_ :=
let is_readonly_pure_lid_ = !Helpers.is_readonly_builtin_lid_ in
fun lid t ->
let ret_t, _ = Helpers.flatten_arrow t in
is_readonly_pure_lid_ lid t
|| (match lid with
| "libcrux_intrinsics" :: _, _ -> ret_t <> TUnit
| [ "Eurydice" ], "vec_len"
| [ "Eurydice" ], "vec_index"
| [ "Eurydice" ], "slice_index_shared"
| [ "Eurydice" ], "slice_index_mut"
| [ "Eurydice" ], "slice_len"
| [ "Eurydice" ], "slice_to_ref_array"
| [ "Eurydice" ], "slice_to_ref_array2"
| [ "Eurydice" ], "slice_subslice_shared"
| [ "Eurydice" ], "slice_subslice_mut"
| [ "Eurydice" ], "slice_subslice_to_shared"
| [ "Eurydice" ], "slice_subslice_to_mut"
| [ "Eurydice" ], "slice_subslice_from_shared"
| [ "Eurydice" ], "slice_subslice_from_mut"
| [ "Eurydice" ], "array_to_slice_shared"
| [ "Eurydice" ], "array_to_slice_mut"
| [ "Eurydice" ], "array_to_subslice_shared"
| [ "Eurydice" ], "array_to_subslice_mut"
| [ "Eurydice" ], "array_repeat"
| [ "core"; "mem" ], "size_of"
| "core" :: "slice" :: _, "as_mut_ptr"
| "core" :: "num" :: _, ("rotate_left" | "from_le_bytes" | "wrapping_add") -> true
| _ -> false)
|| Hashtbl.mem readonly_lids lid
||
match Hashtbl.find_opt readonly_map lid with
| Some body ->
let ro = Helpers.is_readonly_c_expression body in
if ro then
Hashtbl.add readonly_lids lid ();
ro
| _ -> false);
let files =
Eurydice.Builtin.files
@ [
Eurydice.PreCleanup.merge
(List.map
(fun filename ->
let llbc = Eurydice.LoadLlbc.load_file filename in
Eurydice.AstOfLlbc.file_of_crate llbc)
!files);
]
in
if !O.no_const then
Printf.printf "⚠️ Not using 'const' for pointer types\n";
Printf.printf "1️⃣ LLBC ➡️ AST\n";
Eurydice.Logging.log "Phase0" "%a" pfiles files;
let files = Eurydice.PreCleanup.precleanup files in
Eurydice.Logging.log "Phase1" "%a" pfiles files;
let errors, files = Krml.Checker.check_everything ~warn:true files in
if errors then
fail __FILE__ __LINE__;
Printf.printf "2️⃣ Cleanup\n";
let config =
if !O.config = "" then
None
else
Some (Eurydice.Bundles.parse_config (Eurydice.Bundles.load_config !O.config))
in
let files =
match config with
| None -> files
| Some config ->
let files = Eurydice.Bundles.bundle files config in
let files = Eurydice.Bundles.libraries files in
let files = Krml.Bundles.topological_sort files in
Krml.KPrint.bprintf "File order after topological sort: %s\n"
(String.concat ", " (List.map fst files));
files
in
let files = Eurydice.Cleanup1.cleanup files in
let files = Eurydice.Cleanup2.rewrite_signed_shifts files in
Eurydice.Logging.log "Phase2" "%a" pfiles files;
let errors, files = Krml.Checker.check_everything ~warn:true files in
if errors then
fail __FILE__ __LINE__;
Printf.printf "3️⃣ Monomorphization, datatypes\n";
let files = Eurydice.Cleanup2.cosmetic#visit_files () files in
let files = Eurydice.Cleanup2.resugar_loops#visit_files () files in
let files = Eurydice.Cleanup1.remove_terminal_returns#visit_files true files in
let files = Eurydice.Cleanup1.remove_terminal_continues#visit_files false files in
Eurydice.Logging.log "Phase2.1" "%a" pfiles files;
(* Sanity check for the big rewriting above. *)
let errors, files = Krml.Checker.check_everything ~warn:true files in
if errors then
fail __FILE__ __LINE__;
Eurydice.Logging.log "Phase2.11" "%a" pfiles files;
let files = Eurydice.Cleanup2.improve_names files in
let files = Eurydice.Cleanup2.recognize_asserts#visit_files () files in
(* Temporary workaround until Aeneas supports nested loops *)
let files = Eurydice.Cleanup2.inline_loops#visit_files () files in
(* Following the krml order of phases here *)
let files = Krml.Inlining.inline_type_abbrevs files in
let files = Krml.Monomorphization.functions files in
Eurydice.Logging.log "Phase2.12" "%a" pfiles files;
let files = Krml.Simplify.optimize_lets files in
let files = Krml.DataTypes.simplify files in
(* Must happen now, before Monomorphization.datatypes, because otherwise
MonomorphizationState.state gets filled with lids that later on get eliminated on the basis
that they were empty structs to begin with, which would send Checker off the rails *)
let files = Krml.DataTypes.remove_empty_structs files in
let files = Krml.Monomorphization.datatypes files in
(* Cannot use remove_unit_buffers as it is technically incorrect *)
let tbl = Hashtbl.create 41 in
let files = (Krml.DataTypes.build_unit_field_table tbl)#visit_files () files in
let files = (Krml.DataTypes.remove_unit_fields tbl)#visit_files () files in
Eurydice.Logging.log "Phase2.13" "%a" pfiles files;
let files = Krml.Inlining.inline files in
let files =
match config with
| None -> files
| Some config -> (
let files = Eurydice.Bundles.reassign_monomorphizations files config in
Eurydice.Logging.log "Phase2.15" "%a" pfiles files;
try
let files = Krml.Bundles.topological_sort files in
files
with e ->
flush stdout;
flush stderr;
Krml.KPrint.bprintf "Error trying to topologically sort files:\n%s\n\n"
(Printexc.to_string e);
Krml.KPrint.bprintf "Consider passing --log Reassign to Eurydice\n";
Krml.KPrint.bprintf "Internal AST before the error:\n%a\n" pfiles files;
fail __FILE__ __LINE__)
in
Eurydice.Logging.log "Phase2.2" "%a" pfiles files;
(* Sanity check for the big rewriting above. *)
let errors, files = Krml.Checker.check_everything ~warn:true files in
if errors then
fail __FILE__ __LINE__;
let files = Krml.Inlining.drop_unused files in
let files = Eurydice.Cleanup2.remove_array_temporaries#visit_files () files in
Eurydice.Logging.log "Phase2.25" "%a" pfiles files;
let files = Eurydice.Cleanup2.remove_array_repeats#visit_files false files in
Eurydice.Logging.log "Phase2.26" "%a" pfiles files;
let ((map, _, _) as map3), files = Krml.DataTypes.everything files in
Eurydice.Cleanup2.fixup_monomorphization_map map;
let files = Eurydice.Cleanup2.remove_discriminant_reads map3 files in
Eurydice.Logging.log "Phase2.3" "%a" pfiles files;
let files = Eurydice.Cleanup2.remove_trivial_ite#visit_files () files in
Eurydice.Logging.log "Phase2.4" "%a" pfiles files;
let files = Eurydice.Cleanup2.remove_trivial_into#visit_files () files in
Eurydice.Logging.log "Phase2.5" "%a" pfiles files;
let files = Eurydice.Cleanup2.remove_literals files in
(* Eurydice does something more involved than krml and performs a conservative
approximation of functions that are known to be pure readonly (i.e.,
functions that do not write to memory). *)
fill_readonly_table files;
let files = Krml.Simplify.optimize_lets files in
Eurydice.Logging.log "Phase2.55" "%a" pfiles files;
let files = Eurydice.Cleanup2.remove_array_from_fn files in
Eurydice.Logging.log "Phase2.6" "%a" pfiles files;
(* remove_array_from_fn, above, creates further opportunities for removing unused functions. *)
let files = Krml.Inlining.drop_unused files in
let files = Eurydice.Cleanup2.remove_implicit_array_copies#visit_files () files in
(* Creates opportunities for removing unused variables *)
let files = Eurydice.Cleanup2.remove_assign_return#visit_files () files in
(* These two need to come before... *)
let files = Krml.Inlining.cross_call_analysis files in
let files = Krml.Simplify.remove_unused files in
Eurydice.Logging.log "Phase2.7" "%a" pfiles files;
(* This chunk which reuses key elements of simplify2 *)
let files = Eurydice.Cleanup2.check_addrof#visit_files () files in
let files = Krml.Simplify.sequence_to_let#visit_files () files in
let files = Eurydice.Cleanup2.hoist#visit_files [] files in
let files = Eurydice.Cleanup2.fixup_hoist#visit_files () files in
Eurydice.Logging.log "Phase2.75" "%a" pfiles files;
let files = Eurydice.Cleanup2.globalize_global_locals files in
Eurydice.Logging.log "Phase2.8" "%a" pfiles files;
let files = Eurydice.Cleanup2.reconstruct_for_loops#visit_files () files in
let files = Krml.Simplify.misc_cosmetic#visit_files () files in
let files = Krml.Simplify.let_to_sequence#visit_files () files in
Eurydice.Logging.log "Phase2.9" "%a" pfiles files;
let files = Eurydice.Cleanup2.float_comments files in
Eurydice.Logging.log "Phase2.95" "%a" pfiles files;
let files = Eurydice.Cleanup2.bonus_cleanups#visit_files [] files in
(* Macros stemming from globals -- FIXME why is this not Krml.AstToCStar.mk_macros_set? *)
let files, macros = Eurydice.Cleanup2.build_macros files in
Eurydice.Logging.log "Phase3" "%a" pfiles files;
(* debug "checker"; *)
let errors, files = Krml.Checker.check_everything ~warn:true files in
if errors then
fail __FILE__ __LINE__;
let scope_env = Krml.Simplify.allocate_c_env files in
Eurydice.Cleanup3.(also_skip_prefix_for_external_types scope_env)#visit_files () files;
let files = Eurydice.Cleanup3.decay_cg_externals#visit_files (scope_env, false) files in
let files = Eurydice.Cleanup3.remove_builtin_decls files in
Eurydice.Logging.log "Phase3.1" "%a" pfiles files;
let c_name_map = Krml.GlobalNames.mapping (fst scope_env) in
let open Krml in
let file_of_map = Bundle.mk_file_of files in
let deps = Bundles.direct_dependencies_with_internal files file_of_map in
let files =
List.map
(fun (f, ds) ->
let is_fine = function
| [ "LowStar"; "Ignore" ], "ignore" | "Eurydice" :: _, _ ->
(* | "core" :: _, _ -> *)
true
| _ -> false
in
( f,
List.filter_map
(fun d ->
match d with
| Krml.Ast.DExternal (_, _, _, _, lid, t, _)
when Krml.Monomorphization.(
(has_variables [ t ] || has_cg_array [ t ]) && not (is_fine lid)) ->
KPrint.bprintf
"Warning: %a is a type/const-polymorphic assumed function, must be implemented \
with a macro, dropping it\n"
Krml.PrintAst.Ops.plid lid;
None
| _ -> Some d)
ds ))
files
in
Eurydice.Logging.log "Phase3.2" "%a" pfiles files;
(* The following phase reads the "target" parameter for each file, if any, from the config
and if set, then it adds the attribute `KRML_ATTRIBUTE_TARGET(target)` to each function
in the generated C file. This is used, in particular, to mark certain functions as only
to be compiled on target architectures like `avx2` *)
let files =
List.map
(fun (f, ds) ->
let open Eurydice.Bundles in
let target_attribute =
match config with
| None -> ""
| Some c -> (
match List.find_opt (fun (x : file) -> x.name = f) c with
| None -> ""
| Some f -> f.target)
in
( f,
List.filter_map
(fun d ->
match d with
| Krml.Ast.DFunction (cc, fl, x, y, t, l, b, e) when target_attribute <> "" ->
Some (Krml.Ast.DFunction (cc, fl @ [ Target target_attribute ], x, y, t, l, b, e))
| _ -> Some d)
ds ))
files
in
Eurydice.Logging.log "Phase3.3" "%a" pfiles files;
let files =
List.map
(fun (f, ds) ->
( f,
List.filter
(fun d -> not (Krml.Idents.LidSet.mem (Krml.Ast.lid_of_decl d) Eurydice.Builtin.skip))
ds ))
files
in
let files = AstToCStar.mk_files files c_name_map Idents.LidSet.empty macros in
(* Uncomment to debug C* AST *)
(* List.iter *)
(* (fun (f, p) -> *)
(* print_endline f; *)
(* print_endline (CStar.show_program p); *)
(* print_endline "") *)
(* files; *)
let headers = CStarToC11.mk_headers c_name_map files in
let deps = CStarToC11.drop_empty_headers deps headers in
let internal_headers =
Bundles.StringSet.of_list
(List.filter_map
(function
| name, C11.Internal _ -> Some name
| _ -> None)
headers)
in
let public_headers =
Bundles.StringSet.of_list
(List.filter_map
(function
| name, C11.Public _ -> Some name
| _ -> None)
headers)
in
let files = CStarToC11.mk_files c_name_map files in
let files = List.filter (fun (_, decls) -> List.length decls > 0) files in
Krml.Output.maybe_create_internal_dir headers;
Krml.Driver.fstar := "dummy";
ignore (Output.write_c files internal_headers deps);
ignore (Output.write_h headers public_headers deps);
Printf.printf "✅ Done\n"
================================================
FILE: cremepat/Lex.ml
================================================
open Sedlexing
open Parse
let digit = [%sedlex.regexp? '0' .. '9']
let integer = [%sedlex.regexp? Plus digit]
let low_alpha = [%sedlex.regexp? 'a' .. 'z']
let up_alpha = [%sedlex.regexp? 'A' .. 'Z']
let anyident = [%sedlex.regexp? up_alpha | low_alpha | '_' | '-' | digit]
let lident = [%sedlex.regexp? low_alpha, Star anyident]
let uident = [%sedlex.regexp? up_alpha, Star anyident]
let uvar = [%sedlex.regexp? '?', Star anyident]
let uvarlist = [%sedlex.regexp? '?', Star anyident, '.', '.']
let locate _ tok = tok, Lexing.dummy_pos, Lexing.dummy_pos
let keywords =
[
"match", MATCH;
"true", TRUE;
"break", BREAK;
"false", FALSE;
"while", WHILE;
"let", LET;
"abort", ABORT;
]
let lines = ref 1
let cur_line = ref 0
let rec token lexbuf =
match%sedlex lexbuf with
| integer ->
let l = Utf8.lexeme lexbuf in
locate lexbuf (INT (int_of_string l))
| uident ->
let l = Utf8.lexeme lexbuf in
locate lexbuf (UIDENT l)
| lident ->
let l = Utf8.lexeme lexbuf in
begin
try locate lexbuf (List.assoc l keywords) with Not_found -> locate lexbuf (LIDENT l)
end
| uvar ->
let l = Utf8.lexeme lexbuf in
let l = String.sub l 1 (String.length l - 1) in
locate lexbuf (UVAR l)
| uvarlist ->
let l = Utf8.lexeme lexbuf in
let l = String.sub l 1 (String.length l - 3) in
locate lexbuf (UVARLIST l)
| "&" -> locate lexbuf AMP
| ";" -> locate lexbuf SEMI
| "->" -> locate lexbuf ARROW
| "," -> locate lexbuf COMMA
| "=" -> locate lexbuf EQUALS
| "[#" -> locate lexbuf LBRACKHASH
| "[" -> locate lexbuf LBRACK
| "]" -> locate lexbuf RBRACK
| "<" -> locate lexbuf LANGLE
| ">" -> locate lexbuf RANGLE
| "{" -> locate lexbuf LCURLY
| "}" -> locate lexbuf RCURLY
| "(#" -> locate lexbuf LPARENHASH
| "(" -> locate lexbuf LPAREN
| ")" -> locate lexbuf RPAREN
(* | "_" -> locate lexbuf UNDERSCORE *)
| "::" -> locate lexbuf COLONCOLON
| ":" -> locate lexbuf COLON
| "\n" ->
incr lines;
cur_line := fst (loc lexbuf);
token lexbuf
| eof -> locate lexbuf EOF
| white_space -> token lexbuf
| any ->
let l = Utf8.lexeme lexbuf in
failwith (Printf.sprintf "unhandled token: %s, len=%d" l (String.length l))
| _ -> assert false
================================================
FILE: cremepat/Parse.mly
================================================
%{
open ParseTree
%}
%token INT
%token UIDENT LIDENT UVAR UVARLIST
%token EOF COMMA EQUALS LBRACK RBRACK LBRACKHASH LANGLE RANGLE LCURLY RCURLY
%token COLON COLONCOLON AMP LPAREN RPAREN LPARENHASH SEMI
%token MATCH TRUE FALSE LET WHILE BREAK ARROW ABORT
%type expr
%type path_item
%type pat
%type typ
%start fragment
%%
(* Identifiers *)
%inline
uident:
| u = UIDENT
{ u }
%inline
lident:
| l = LIDENT
{ l }
%inline
ident:
| s = LIDENT
{ s }
| s = UIDENT
{ s }
(* Paths *)
path_item:
| i = ident
{ Name i }
| p = UVAR
{ if p = "" then Wild else Var p }
| _p = UVARLIST
{ failwith "TODO" }
%inline
path:
| p = iseparated_twoplus_list(COLONCOLON, path_item)
{ p }
(* Helpers *)
%inline iseparated_twoplus_list(separator, X):
x1 = X; separator; x2 = X
{ [ x1; x2 ] }
| x1 = X; separator; x2 = X; separator; xs = separated_nonempty_list(separator, X)
{ x1 :: x2 :: xs }
%inline
with_vars(X):
| x = UVAR
{ PatternVar (if x = "" then "_" ^ gensym () else x) }
| x = UVARLIST
{ ListPatternVar (if x = "" then "_" ^ gensym () else x) }
| x = X
{ Fixed x }
%inline
fixed(X):
| x = X
{ Fixed x }
(* Types *)
pre_typ:
| t = typ ts = delimited(LANGLE, separated_list(COMMA, typ), RANGLE)
{ TApp (t, ts) }
| p = path
{ TQualified p }
typ:
| t = with_vars(pre_typ)
{ t }
(* Patterns *)
pre_pat:
| u = uident
{ Cons (u, []) }
| u = uident p = delimited(LPAREN, separated_list(COMMA, pat), RPAREN)
{ Cons (u, p) }
| u = uident p = pat
{ Cons (u, [ p ]) }
pat:
| t = with_vars(pre_pat)
{ t }
(* Expressions *)
expr:
| e = fixed(pre_expr)
{ e }
| e = seq_expr
{ e }
pre_expr:
| LET b = lident EQUALS e1 = app_expr SEMI e2 = expr
{ Let (b, e1, e2) }
seq_expr:
| e = fixed(pre_seq_expr)
{ e }
| e = app_expr
{ e }
pre_seq_expr:
| e1 = app_expr SEMI e2 = seq_expr
{ match e2 with Fixed (Sequence e2) -> Sequence (e1 :: e2) | _ -> Sequence [ e1; e2 ] }
app_expr:
| e = fixed(pre_app_expr)
{ e }
| e = index_expr
{ e }
pre_app_expr:
| head = app_expr
cgs = ioption(delimited(LBRACKHASH, separated_list(COMMA, expr), RBRACK))
methods = ioption(delimited(LPARENHASH, separated_list(COMMA, expr), RPAREN))
ts = ioption(delimited(LANGLE, separated_list(COMMA, typ), RANGLE))
args = delimited(LPAREN, separated_list(COMMA, expr), RPAREN)
{
let cgs = Option.value ~default:[] cgs in
let methods = Option.value ~default:[] methods in
let ts = Option.value ~default:[] ts in
App { head; cgs; methods; ts; args }
}
| AMP e = index_expr
{ Addr e }
index_expr:
| e = fixed(pre_index_expr)
{ e }
| e = atomic_expr
{ e }
pre_index_expr:
| e1 = index_expr e2 = delimited(LBRACK, expr, RBRACK)
{ Index (e1, e2) }
atomic_expr:
| e = with_vars(pre_atomic_expr)
{ e }
| e = delimited(LPAREN, expr, RPAREN)
{ e }
pre_atomic_expr:
| WHILE e1 = index_expr e2 = delimited(LCURLY, expr, RCURLY)
{ While (e1, e2) }
| MATCH e = index_expr bs = delimited(LCURLY, separated_list(COMMA, separated_pair(pat, ARROW, expr)), RCURLY)
{ Match (e, bs) }
| e = delimited(LCURLY, separated_nonempty_list(COMMA, separated_pair(lident, COLON, expr)), RCURLY)
{ Record e }
| i = INT
{ Int i }
| p = path
{ Qualified p }
| x = lident
{ BoundVar x }
| BREAK
{ Break }
| ABORT
{ Abort }
| FALSE
{ Bool false }
| TRUE
{ Bool true }
(* Entry point *)
fragment:
| e = expr EOF
{ e }
================================================
FILE: cremepat/ParseTree.ml
================================================
(* Strictly a parse tree *)
type pre_expr =
(* Binding most loosely *)
| Let of string * expr * expr
| Sequence of expr list
| App of { head : expr; cgs : expr list; methods : expr list; ts : typ list; args : expr list }
| Addr of expr
| Index of expr * expr
(* Atomic -- we terminate matches and loops using braces, we are not barbarians. *)
| While of expr * expr
| Match of expr * branch list
| Record of (string * expr) list
| Int of int
| Qualified of path
| BoundVar of string
| Break
| Abort
| Bool of bool
and expr = pre_expr with_vars
and 'a with_vars = PatternVar of string | ListPatternVar of string | Fixed of 'a
and path = path_item list
and path_item = Name of string | Wild | Var of string
and branch = pat * expr
and pre_pat = Cons of string * pat list
and pat = pre_pat with_vars
and pre_typ = TQualified of path | TApp of typ * typ list
and typ = pre_typ with_vars
let gensym =
let r = ref 0 in
fun () ->
incr r;
"$x" ^ string_of_int !r
================================================
FILE: cremepat/README.md
================================================
CREMEPAT: CREdible, Meta-Extensible PATterns
--------------------------------------------
Write concrete syntax instead of 50 lines of deeply-embedded pattern matches. See lib/Cleanup2.ml
================================================
FILE: cremepat/cremepat.ml
================================================
module Terminal = struct
let mkcolor x = Printf.sprintf "\x1b[38;5;%dm" x
let green = mkcolor 119
let red = mkcolor 203
let blue = mkcolor 81
let yellow = mkcolor 227
let orange = mkcolor 202
let underline = "\x1b[4m"
let reset = "\x1b[0m"
end
let fail fmt =
let b = Buffer.create 256 in
Printf.kbprintf (fun b -> failwith (Buffer.contents b)) b fmt
let parse arg =
let the_parser = MenhirLib.Convert.Simplified.traditional2revised Parse.fragment in
let lexbuf = Sedlexing.Utf8.from_string arg in
try the_parser (fun _ -> Lex.token lexbuf) with
| (Sedlexing.MalFormed | Sedlexing.InvalidCodepoint _) as e ->
Printf.eprintf "Lexing error in: %s\n" arg;
raise e
| Parse.Error as e ->
let start, end_ = Sedlexing.loc lexbuf in
let start = start - !Lex.cur_line in
let end_ = end_ - !Lex.cur_line in
let buf = Buffer.create 256 in
List.iteri
(fun i line ->
Buffer.add_string buf line;
Buffer.add_char buf '\n';
if i + 1 = !Lex.lines then begin
Buffer.add_string buf Terminal.red;
for _j = 0 to start do
Buffer.add_char buf ' '
done;
for _j = start to end_ - 1 do
Buffer.add_char buf '^'
done;
Buffer.add_string buf Terminal.reset;
Buffer.add_char buf '\n'
end)
(String.split_on_char '\n' arg);
Printf.eprintf "Parse error, line %d, characters %d-%d: %s\n" !Lex.lines start end_
(Buffer.contents buf);
raise e
open Ppxlib
(* Environments for the compile-time compilation of parse trees to OCaml pattern ASTs *)
type env = string list
let empty = []
let push env x = x :: env
let find env x =
let exception Found of int in
try
List.iteri
(fun i x' ->
if x = x' then
raise (Found i))
env;
raise Not_found
with Found i -> i
(* Helpers to build nodes *)
let lident ~loc x = { txt = Lident x; loc }
let rec ppat_list ~loc pats =
let open Ast_builder.Default in
List.fold_right
(fun pat acc -> ppat_construct ~loc (lident ~loc "::") (Some (ppat_tuple ~loc [ pat; acc ])))
pats
(ppat_construct ~loc (lident ~loc "[]") None)
(* Variants for things that are not expressions (i.e. not 'a nodes) *)
let ppat_cons_many' ~loc cons args =
let open Ast_builder.Default in
ppat_construct ~loc (lident ~loc cons) (Some (ppat_tuple ~loc args))
let ppat_cons_one' ~loc cons arg =
let open Ast_builder.Default in
ppat_construct ~loc (lident ~loc cons) (Some arg)
let ppat_cons_zero' ~loc cons =
let open Ast_builder.Default in
ppat_construct ~loc (lident ~loc cons) None
let ppat_string ~loc s =
let open Ast_builder.Default in
ppat_constant ~loc (Pconst_string (s, loc, None))
let ppat_int ~loc s =
let open Ast_builder.Default in
ppat_constant ~loc (Pconst_integer (string_of_int s, None))
let ppat_bool ~loc s = ppat_cons_zero' ~loc (string_of_bool s)
(* Variants that produce the { node = ...; _ } part automatically *)
let ppat_node ~loc pat =
let open Ast_builder.Default in
ppat_record ~loc [ lident ~loc "node", pat ] Open
let ppat_cons_many ~loc cons args = ppat_node ~loc (ppat_cons_many' ~loc cons args)
let ppat_cons_one ~loc cons arg = ppat_node ~loc (ppat_cons_one' ~loc cons arg)
let ppat_cons_zero ~loc cons = ppat_node ~loc (ppat_cons_zero' ~loc cons)
let compile_parse_tree (env : env) loc
(pt : ParseTree.expr) (* : Astlib.Ast_503.Parsetree.pattern *) =
let open Ast_builder.Default in
(* Helpers *)
(* Compiling a node where only non-list unification variables may appear *)
let rec compile_with_var : 'a. env -> 'a ParseTree.with_vars -> (env -> 'a -> _) -> _ =
fun env pt compile_pre ->
match pt with
| Fixed e -> compile_pre env e
| PatternVar txt -> ppat_var ~loc { txt; loc }
| ListPatternVar s -> fail "[cremepat]: list pattern ?%s.. appears in unexpected position" s
(* Special treatment for lists of 'a that are allowed to contain list unification variables --
recurse into one of the specialized variants of this for AST positions that admit lists. Note
that the syntax does not enforce that list unification variables only appear where allowed --
there is some implicit typing depending on whether you recurse via compile_with_var or
compile_list_pattern. *)
and compile_list_pattern : 'a. env -> 'a ParseTree.with_vars list -> (env -> 'a -> _) -> _ =
fun env pts compile_pre ->
match pts with
| [] -> ppat_construct ~loc (lident ~loc "[]") None
| ListPatternVar txt :: [] -> ppat_var ~loc { txt; loc }
| ListPatternVar s :: _ ->
fail "[cremepat]: list pattern ?%s.. should only appear in tail position" s
| PatternVar txt :: pts ->
ppat_construct ~loc (lident ~loc "::")
(Some
(ppat_tuple ~loc
[ ppat_var ~loc { txt; loc }; compile_list_pattern env pts compile_pre ]))
| Fixed pt :: pts ->
ppat_construct ~loc (lident ~loc "::")
(Some (ppat_tuple ~loc [ compile_pre env pt; compile_list_pattern env pts compile_pre ]))
and compile env pt = compile_with_var env pt compile_pre_expr
and compile_expr_list_pattern env pt = compile_list_pattern env pt compile_pre_expr
and compile_pre_expr env pt =
match pt with
| ParseTree.Let (b, e1, e2) ->
let p1 = compile env e1 in
let env = push env b in
let p2 = compile env e2 in
(* ELet (_, p1, p2) *)
ppat_cons_many ~loc "ELet" [ ppat_any ~loc; p1; p2 ]
| Sequence ps -> ppat_cons_one ~loc "ESequence" (compile_expr_list_pattern env ps)
| App { head; cgs; methods; ts; args } ->
(* EApp (ETApp (e, ts), es) *)
ppat_cons_many ~loc "EApp"
[
ppat_cons_many ~loc "ETApp"
[
compile env head;
compile_expr_list_pattern env cgs;
compile_expr_list_pattern env methods;
compile_typ_list_pattern env ts;
];
ppat_list ~loc (List.map (compile env) args);
]
| Addr e -> ppat_cons_one ~loc "EAddrOf" (compile env e)
| Index (e1, e2) ->
let p1 = compile env e1 in
let p2 = compile env e2 in
ppat_cons_many ~loc "EBufRead" [ p1; p2 ]
| While (e1, e2) ->
let p1 = compile env e1 in
let p2 = compile env e2 in
ppat_cons_many ~loc "EWhile" [ p1; p2 ]
| Match (e, bs) ->
let e = compile env e in
ppat_cons_many ~loc "EMatch"
[
ppat_any ~loc;
(* no syntax to match on match flavor *)
e;
ppat_list ~loc
(List.map
(fun (p, e) ->
let p = compile_pat env p in
let e = compile env e in
ppat_tuple ~loc
[ ppat_any ~loc; (* no syntax to match on binders in patterns *) p; e ])
bs);
]
| Record es ->
ppat_cons_one ~loc "EFlat"
(ppat_list ~loc
(List.map
(fun (f, e) ->
ppat_tuple ~loc [ ppat_cons_one' ~loc "Some" (ppat_string ~loc f); compile env e ])
es))
| Int i ->
ppat_cons_many ~loc "EConstant"
[
ppat_any ~loc;
(* no syntax to match on width of constants *)
ppat_string ~loc (string_of_int i);
]
| Qualified path -> ppat_cons_one ~loc "EQualified" (compile_path env path)
| BoundVar s ->
let i = find env s in
ppat_cons_one ~loc "EBound" (ppat_int ~loc i)
| Break -> ppat_cons_zero ~loc "EBreak"
| Bool b -> ppat_cons_one ~loc "EBool" (ppat_bool ~loc b)
| Abort -> ppat_cons_many ~loc "EAbort" [ ppat_any ~loc; ppat_any ~loc ]
(* Paths *)
and compile_path env (pt : ParseTree.path) =
let m, n =
match List.rev pt with
| n :: m -> List.rev m, n
| _ -> failwith "impossible"
in
ppat_tuple ~loc [ ppat_list ~loc (List.map (compile_path_item env) m); compile_path_item env n ]
and compile_path_item _env (pt : ParseTree.path_item) =
match pt with
| Wild -> ppat_any ~loc
| Name s -> ppat_string ~loc s
| Var txt -> ppat_var ~loc { txt; loc }
(* Types *)
and _compile_typ env pt = compile_with_var env pt compile_pre_typ
and compile_typ_list_pattern env (es : ParseTree.typ list) =
compile_list_pattern env es compile_pre_typ
and compile_pre_typ env (pt : ParseTree.pre_typ) =
match pt with
| TQualified path -> ppat_cons_one' ~loc "TQualified" (compile_path env path)
| TApp (Fixed (TQualified p), ts) ->
ppat_cons_many' ~loc "TApp" [ compile_path env p; compile_typ_list_pattern env ts ]
| TApp (PatternVar p, ts) ->
ppat_cons_many' ~loc "TApp"
[ ppat_var ~loc { txt = p; loc }; compile_typ_list_pattern env ts ]
| TApp (_, _) -> failwith "incorrect type application left-hand side"
(* Patterns *)
and compile_pat env pt = compile_with_var env pt compile_pre_pat
and compile_pat_list_pattern env (es : ParseTree.pat list) =
compile_list_pattern env es compile_pre_pat
and compile_pre_pat env (pt : ParseTree.pre_pat) =
match pt with
| Cons (cons, ps) ->
ppat_cons_many ~loc "PCons" [ ppat_string ~loc cons; compile_pat_list_pattern env ps ]
in
compile env pt
let expand ~ctxt (payload : string) =
let pt = parse payload in
let loc = Expansion_context.Extension.extension_point_loc ctxt in
compile_parse_tree empty loc pt
let my_extension =
Extension.V3.declare "cremepat" Pattern Ast_pattern.(single_expr_payload (estring __)) expand
let rule = Ppxlib.Context_free.Rule.extension my_extension
let () = Driver.register_transformation ~rules:[ rule ] "cremepat"
================================================
FILE: cremepat/dune
================================================
(library
(name cremepat)
(kind ppx_rewriter)
(libraries ppxlib menhirLib)
(preprocess
(pps sedlex.ppx))
(flags
(:standard
-warn-error
-A
-w
@1-2@3-7@8..12@14..21@23..29-30@31..38-39-40-41@43@57)))
(menhir
(modules Parse))
; (flags --trace))
================================================
FILE: dune
================================================
(data_only_dirs charon karamel libcrux)
================================================
FILE: dune-project
================================================
(lang dune 3.13)
(name eurydice)
(generate_opam_files true)
(source
(github AeneasVerif/eurydice))
(authors "Son Ho" "Jonathan Protzenko")
(maintainers "Son Ho" "Jonathan Protzenko")
(license Apache-2.0)
(package
(name eurydice)
(synopsis "A Rust to C translator")
(description "Eurydice builds upon Charon to take existing Rust code and
translate it to C")
(depends
ocaml
dune
yaml
(terminal (>= 0.4.0))
)
)
(using menhir 3.0)
================================================
FILE: eurydice.opam
================================================
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "A Rust to C translator"
description: """
Eurydice builds upon Charon to take existing Rust code and
translate it to C"""
maintainer: ["Son Ho" "Jonathan Protzenko"]
authors: ["Son Ho" "Jonathan Protzenko"]
license: "Apache-2.0"
homepage: "https://github.com/AeneasVerif/eurydice"
bug-reports: "https://github.com/AeneasVerif/eurydice/issues"
depends: [
"ocaml"
"dune" {>= "3.13"}
"yaml"
"terminal" {>= "0.4.0"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/AeneasVerif/eurydice.git"
================================================
FILE: flake.nix
================================================
{
inputs = {
nixpkgs.follows = "charon/nixpkgs";
flake-utils.follows = "karamel/flake-utils";
karamel.url = "github:FStarLang/karamel";
karamel.inputs.nixpkgs.follows = "nixpkgs";
charon.url = "github:AeneasVerif/charon";
crane.follows = "charon/crane";
libcrux.url = "github:cryspen/libcrux";
googletest.follows = "libcrux/googletest";
benchmark.follows = "libcrux/benchmark";
json.follows = "libcrux/json";
};
outputs =
{ self
, flake-utils
, nixpkgs
, ...
} @ inputs:
flake-utils.lib.eachDefaultSystem (system:
let
pkgs = import nixpkgs { inherit system; };
karamel = inputs.karamel.packages.${system}.default.override {
ocamlPackages = pkgs.ocamlPackages;
};
krml = karamel.passthru.lib;
charon-packages = inputs.charon.packages.${system};
charon-ml = charon-packages.charon-ml.override {
ocamlPackages = pkgs.ocamlPackages;
};
charon = charon-packages.default;
craneLib = (inputs.crane.mkLib pkgs).overrideToolchain charon-packages.rustToolchain;
package =
{ ocamlPackages
, removeReferencesTo
, clangStdenv
, symlinks
, version
, which
, z3
, cmake
, git
, mold-wrapped
, ninja
, gnugrep
, charon
, charon-ml
, krml
, symlinkJoin
, clang
, craneLib
}:
let
eurydice = ocamlPackages.buildDunePackage {
pname = "eurydice";
inherit version;
src = ./.;
nativeBuildInputs = [ gnugrep ] ++ (with ocamlPackages; [ menhir ]);
propagatedBuildInputs = [ krml charon-ml ocamlPackages.terminal ocamlPackages.yaml ] ++ (with ocamlPackages; [ menhirLib ]);
postInstall = ''
ln -s ${charon}/bin/charon $out/bin/charon
'';
passthru = {
tests = clangStdenv.mkDerivation rec {
name = "tests";
src = ./.;
IN_CI = 1; # Tell the `check-dependency` script to not check for charon/karamel commit hashes.
KRML_HOME = karamel.src;
EURYDICE = "${eurydice}/bin/eurydice";
CHARON = "${charon}/bin/charon";
CMAKE_FLAGS = [
"-DFETCHCONTENT_SOURCE_DIR_GOOGLETEST=${inputs.googletest}"
"-DFETCHCONTENT_SOURCE_DIR_BENCHMARK=${inputs.benchmark}"
"-DFETCHCONTENT_SOURCE_DIR_JSON=${inputs.json}"
"-DFETCHCONTENT_FULLY_DISCONNECTED=ON"
];
# Pre-build the cargo dependencies; required for `cargo` to
# work inside nix since nix builders don't have network
# access.
cargoVendorDir = craneLib.vendorCargoDeps { cargoLock = ./libcrux-Cargo.lock; };
cargoArtifacts = craneLib.buildDepsOnly {
src = inputs.libcrux.sourceInfo.outPath;
inherit cargoVendorDir;
# Only build the libcrux-ml-kem package.
cargoExtraArgs = "-p libcrux-ml-kem";
# Run `cargo check` too, to make sure we include the dev-dependencies.
doCheck = true;
};
nativeBuildInputs = [
cmake
git
mold-wrapped
ninja
# Crane hooks that will use the
# `cargoArtifacts`/`cargoVendorDir` to tell cargo where to
# find its dependencies.
craneLib.configureCargoCommonVarsHook
craneLib.configureCargoVendoredDepsHook
craneLib.inheritCargoArtifactsHook
pkgs.zstd # For the inheritCargoArtifactsHook hooks.
];
buildInputs = [ eurydice ];
dontUseCmakeConfigure = true;
buildPhase = ''
# Prepare the libcrux directory.
cp --no-preserve=mode,ownership -rf ${inputs.libcrux.sourceInfo.outPath} libcrux
# Symlink karamel so we find its headers.
ln -s $KRML_HOME karamel
# Run the tests
make -o all test
# Remove generated files that we don't want to compare.
shopt -s globstar
rm -f out/**/a.out
# Check that there are no differences between the generated
# outputs and the committed outputs.
if diff -rq "${./out}" out; then
echo "Ok: the regenerated files are the same as the checked out files"
else
echo "Error: the regenerated files differ from the checked out files"
diff -ru "${./out}" out
exit 1
fi
'';
installPhase = ''touch $out'';
};
};
};
in
eurydice;
in
rec {
packages = {
default = pkgs.callPackage package {
inherit charon charon-ml krml craneLib;
version = self.rev or "dirty";
};
inherit charon karamel;
};
checks = {
default = packages.default.tests;
format = pkgs.runCommand "format-check"
{
src = ./.;
nativeBuildInputs = [
pkgs.bash
pkgs.gnumake
pkgs.llvmPackages_18.clang-tools # For clang-format
pkgs.ocamlPackages.ocaml
pkgs.ocamlPackages.ocamlformat_0_27_0
pkgs.ocamlPackages.dune_3
];
} ''
cp -r $src src
chmod u+w src
cd src
bash ./scripts/format.sh check
touch $out
'';
};
devShells.ci = pkgs.mkShell { packages = [ pkgs.jq ]; };
devShells.default = (pkgs.mkShell.override { stdenv = pkgs.clangStdenv; }) {
OCAMLRUNPARAM = "b"; # Get backtrace on exception
packages = [
pkgs.jq
pkgs.llvmPackages_18.clang-tools # For clang-format
pkgs.ocamlPackages.ocaml
pkgs.ocamlPackages.ocamlformat_0_27_0
pkgs.ocamlPackages.menhir
# ocaml-lsp's version must match the ocaml version used. Pinning
# this here to save me a headache.
pkgs.ocamlPackages.ocaml-lsp
pkgs.rustup
];
buildInputs = [ charon.buildInputs ];
nativeBuildInputs = [ charon.nativeBuildInputs pkgs.clang ];
inputsFrom = [
packages.default
packages.default.tests
charon-ml
];
};
});
}
================================================
FILE: include/eurydice_glue.h
================================================
#pragma once
#include
#include
#include
#include
#include
#ifdef _MSC_VER
// For __popcnt
#include
#endif
#include "krml/internal/target.h"
#include "krml/lowstar_endianness.h"
// C++ HELPERS
#if defined(__cplusplus)
#ifndef KRML_HOST_EPRINTF
#define KRML_HOST_EPRINTF(...) fprintf(stderr, __VA_ARGS__)
#endif
#include
#ifndef __cpp_lib_type_identity
template struct type_identity {
using type = T;
};
template using type_identity_t = typename type_identity::type;
#else
using std::type_identity_t;
#endif
#define KRML_UNION_CONSTRUCTOR(T) \
template \
constexpr T(int t, V U::*m, type_identity_t v) : tag(t) { \
val.*m = std::move(v); \
} \
T() = default;
#endif
// GENERAL-PURPOSE STUFF
#define LowStar_Ignore_ignore(e, t, _ret_t) ((void)e)
#define EURYDICE_ASSERT(test, msg) \
do { \
if (!(test)) { \
fprintf(stderr, "assertion \"%s\" failed: file \"%s\", line %d\n", msg, \
__FILE__, __LINE__); \
exit(255); \
} \
} while (0)
// SIZEOF, ALIGNOF
#define Eurydice_sizeof(t) sizeof(t)
#define Eurydice_alignof(t) alignof(t)
// SLICES, ARRAYS, ETC.
// For convenience, we give these common slice types, below, a distinguished
// status and rather than emit them in the client code, we skip their
// code-generation in Cleanup3.ml and write them by hand here. This makes it
// easy to write interop code that brings those definitions in scope.
// &[u8]
typedef struct Eurydice_borrow_slice_u8_s {
const uint8_t *ptr;
size_t meta;
} Eurydice_borrow_slice_u8;
// &[u16]
typedef struct Eurydice_borrow_slice_i16_s {
const int16_t *ptr;
size_t meta;
} Eurydice_borrow_slice_i16;
// &mut [u8]
typedef struct Eurydice_mut_borrow_slice_u8_s {
uint8_t *ptr;
size_t meta;
} Eurydice_mut_borrow_slice_u8;
// &mut [u16]
typedef struct Eurydice_mut_borrow_slice_i16_s {
int16_t *ptr;
size_t meta;
} Eurydice_mut_borrow_slice_i16;
#if defined(__cplusplus)
#define KRML_CLITERAL(type) type
#else
#define KRML_CLITERAL(type) (type)
#endif
#if defined(__cplusplus) && defined(__cpp_designated_initializers) || \
!(defined(__cplusplus))
#define EURYDICE_CFIELD(X) X
#else
#define EURYDICE_CFIELD(X)
#endif
#define Eurydice_array_repeat(dst, len, init, t) \
ERROR "should've been desugared"
// Copy a slice with memcopy
#define Eurydice_slice_copy(dst, src, t) \
memcpy(dst.ptr, src.ptr, dst.meta * sizeof(t))
#define core_array___T__N___as_slice(len_, ptr_, t, ret_t) \
(KRML_CLITERAL(ret_t){EURYDICE_CFIELD(.ptr =)(ptr_)->data, \
EURYDICE_CFIELD(.meta =) len_})
#define core_array__core__clone__Clone_for__T__N___clone(len, src, elem_type, \
_ret_t) \
(*(src))
#define TryFromSliceError uint8_t
#define core_array_TryFromSliceError uint8_t
// Distinguished support for some PartialEq trait implementations
//
// core::cmp::PartialEq<@Array> for @Array
#define Eurydice_array_eq(sz, a1, a2, t) \
(memcmp((a1)->data, (a2)->data, sz * sizeof(t)) == 0)
// core::cmp::PartialEq<&0 (@Slice)> for @Array
#define Eurydice_array_eq_slice_shared(sz, a1, s2, t, _) \
(memcmp((a1)->data, (s2)->ptr, sz * sizeof(t)) == 0)
#define Eurydice_array_eq_slice_mut(sz, a1, s2, t, _) \
Eurydice_array_eq_slice_shared(sz, a1, s2, t, _)
// DEPRECATED -- should no longer be generated
#define core_array_equality__core__cmp__PartialEq__Array_U__N___for__Array_T__N___eq( \
sz, a1, a2, t, _, _ret_t) \
Eurydice_array_eq(sz, a1, a2, t)
#define core_array_equality__core__cmp__PartialEq__0___Slice_U____for__Array_T__N___eq( \
sz, a1, a2, t, _, _ret_t) \
Eurydice_array_eq(sz, a1, ((a2)->ptr), t)
#define core_cmp_impls__core__cmp__PartialEq__0_mut__B___for__1_mut__A___eq( \
_m0, _m1, src1, src2, _0, _1, T) \
Eurydice_slice_eq(src1, src2, _, _, T, _)
#define Eurydice_slice_split_at(slice, mid, element_type, ret_t) \
KRML_CLITERAL(ret_t) { \
EURYDICE_CFIELD(.fst =){EURYDICE_CFIELD(.ptr =)((slice).ptr), \
EURYDICE_CFIELD(.meta =) mid}, \
EURYDICE_CFIELD(.snd =) { \
EURYDICE_CFIELD(.ptr =) \
((slice).ptr + mid), EURYDICE_CFIELD(.meta =)((slice).meta - mid) \
} \
}
#define Eurydice_slice_split_at_mut(slice, mid, element_type, ret_t) \
KRML_CLITERAL(ret_t) { \
EURYDICE_CFIELD(.fst =){EURYDICE_CFIELD(.ptr =)((slice).ptr), \
EURYDICE_CFIELD(.meta =) mid}, \
EURYDICE_CFIELD(.snd =) { \
EURYDICE_CFIELD(.ptr =) \
((slice).ptr + mid), EURYDICE_CFIELD(.meta =)((slice).meta - mid) \
} \
}
// Conversion of slice to an array, rewritten (by Eurydice) to name the
// destination array, since arrays are not values in C.
// N.B.: see note in karamel/lib/Inlining.ml if you change this.
#define Eurydice_slice_to_ref_array2(len_, src, arr_ptr, t_ptr, t_arr, t_err, \
t_res) \
(src.meta >= len_ \
? ((t_res){.tag = core_result_Ok, .val = {.case_Ok = arr_ptr}}) \
: ((t_res){.tag = core_result_Err, .val = {.case_Err = 0}}))
// CORE STUFF (conversions, endianness, ...)
// We slap extern "C" on declarations that intend to implement a prototype
// generated by Eurydice, because Eurydice prototypes are always emitted within
// an extern "C" block, UNLESS you use -fcxx17-compat, in which case, you must
// pass -DKRML_CXX17_COMPAT="" to your C++ compiler.
#if defined(__cplusplus) && !defined(KRML_CXX17_COMPAT)
extern "C" {
#endif
#define core_hint_black_box(X, _0, _1) (X)
// [ u8; 2 ]
typedef struct Eurydice_array_u8x2_s {
uint8_t data[2];
} Eurydice_array_u8x2;
// [ u8; 4 ]
typedef struct Eurydice_array_u8x4_s {
uint8_t data[4];
} Eurydice_array_u8x4;
// [ u8; 8 ]
typedef struct Eurydice_array_u8x8_s {
uint8_t data[8];
} Eurydice_array_u8x8;
static inline uint16_t core_num__u16__from_le_bytes(Eurydice_array_u8x2 buf) {
return load16_le(buf.data);
}
static inline Eurydice_array_u8x4 core_num__u32__to_be_bytes(uint32_t src) {
// TODO: why not store32_be?
Eurydice_array_u8x4 a;
uint32_t x = htobe32(src);
memcpy(a.data, &x, 4);
return a;
}
static inline Eurydice_array_u8x4 core_num__u32__to_le_bytes(uint32_t src) {
Eurydice_array_u8x4 a;
store32_le(a.data, src);
return a;
}
static inline uint32_t core_num__u32__from_le_bytes(Eurydice_array_u8x4 buf) {
return load32_le(buf.data);
}
static inline Eurydice_array_u8x8 core_num__u64__to_le_bytes(uint64_t v) {
Eurydice_array_u8x8 a;
store64_le(a.data, v);
return a;
}
static inline uint64_t core_num__u64__from_le_bytes(Eurydice_array_u8x8 buf) {
return load64_le(buf.data);
}
static inline int64_t
core_convert_num__core__convert__From_i32__for_i64__from(int32_t x) {
return x;
}
static inline uint64_t
core_convert_num__core__convert__From_u8__for_u64__from(uint8_t x) {
return x;
}
static inline uint64_t
core_convert_num__core__convert__From_u16__for_u64__from(uint16_t x) {
return x;
}
static inline size_t
core_convert_num__core__convert__From_u16__for_usize__from(uint16_t x) {
return x;
}
static inline uint32_t core_num__u8__count_ones(uint8_t x0) {
#ifdef _MSC_VER
return __popcnt(x0);
#else
return __builtin_popcount(x0);
#endif
}
static inline uint32_t core_num__u32__count_ones(uint32_t x0) {
#ifdef _MSC_VER
return __popcnt(x0);
#else
return __builtin_popcount(x0);
#endif
}
static inline uint32_t core_num__i32__count_ones(int32_t x0) {
#ifdef _MSC_VER
return __popcnt(x0);
#else
return __builtin_popcount(x0);
#endif
}
static inline size_t core_cmp_impls__core__cmp__Ord_for_usize__min(size_t a,
size_t b) {
if (a <= b)
return a;
else
return b;
}
// unsigned overflow wraparound semantics in C
static inline uint8_t core_num__u8__wrapping_sub(uint8_t x, uint8_t y) {
return x - y;
}
static inline uint8_t core_num__u8__wrapping_add(uint8_t x, uint8_t y) {
return x + y;
}
static inline uint8_t core_num__u8__wrapping_mul(uint8_t x, uint8_t y) {
return x * y;
}
static inline uint16_t core_num__u16__wrapping_sub(uint16_t x, uint16_t y) {
return x - y;
}
static inline uint16_t core_num__u16__wrapping_add(uint16_t x, uint16_t y) {
return x + y;
}
static inline uint16_t core_num__u16__wrapping_mul(uint16_t x, uint16_t y) {
return x * y;
}
static inline uint32_t core_num__u32__wrapping_sub(uint32_t x, uint32_t y) {
return x - y;
}
static inline uint32_t core_num__u32__wrapping_add(uint32_t x, uint32_t y) {
return x + y;
}
static inline uint32_t core_num__u32__wrapping_mul(uint32_t x, uint32_t y) {
return x * y;
}
static inline uint64_t core_num__u64__wrapping_sub(uint64_t x, uint64_t y) {
return x - y;
}
static inline uint64_t core_num__u64__wrapping_add(uint64_t x, uint64_t y) {
return x + y;
}
static inline uint64_t core_num__u64__wrapping_mul(uint64_t x, uint64_t y) {
return x * y;
}
static inline size_t core_num__usize__wrapping_sub(size_t x, size_t y) {
return x - y;
}
static inline size_t core_num__usize__wrapping_add(size_t x, size_t y) {
return x + y;
}
static inline size_t core_num__usize__wrapping_mul(size_t x, size_t y) {
return x * y;
}
static inline int8_t core_num__i8__wrapping_add(int8_t x, int8_t y) {
return (int8_t)((uint8_t)x + (uint8_t)y);
}
static inline int8_t core_num__i8__wrapping_sub(int8_t x, int8_t y) {
return (int8_t)((uint8_t)x - (uint8_t)y);
}
static inline int8_t core_num__i8__wrapping_mul(int8_t x, int8_t y) {
return (int8_t)((uint8_t)x * (uint8_t)y);
}
static inline int16_t core_num__i16__wrapping_add(int16_t x, int16_t y) {
return (int16_t)((uint16_t)x + (uint16_t)y);
}
static inline int16_t core_num__i16__wrapping_sub(int16_t x, int16_t y) {
return (int16_t)((uint16_t)x - (uint16_t)y);
}
static inline int16_t core_num__i16__wrapping_mul(int16_t x, int16_t y) {
return (int16_t)((uint16_t)x * (uint16_t)y);
}
static inline int32_t core_num__i32__wrapping_add(int32_t x, int32_t y) {
return (int32_t)((uint32_t)x + (uint32_t)y);
}
static inline int32_t core_num__i32__wrapping_sub(int32_t x, int32_t y) {
return (int32_t)((uint32_t)x - (uint32_t)y);
}
static inline int32_t core_num__i32__wrapping_mul(int32_t x, int32_t y) {
return (int32_t)((uint32_t)x * (uint32_t)y);
}
static inline int64_t core_num__i64__wrapping_add(int64_t x, int64_t y) {
return (int64_t)((uint64_t)x + (uint64_t)y);
}
static inline int64_t core_num__i64__wrapping_sub(int64_t x, int64_t y) {
return (int64_t)((uint64_t)x - (uint64_t)y);
}
static inline int64_t core_num__i64__wrapping_mul(int64_t x, int64_t y) {
return (int64_t)((uint64_t)x * (uint64_t)y);
}
static inline int8_t core_num__i8__wrapping_neg(int8_t x) {
return (int8_t)(-(uint8_t)x);
}
static inline int16_t core_num__i16__wrapping_neg(int16_t x) {
return (int16_t)(-(uint16_t)x);
}
static inline int32_t core_num__i32__wrapping_neg(int32_t x) {
return (int32_t)(-(uint32_t)x);
}
static inline int64_t core_num__i64__wrapping_neg(int64_t x) {
return (int64_t)(-(uint64_t)x);
}
static inline uint64_t core_num__u64__rotate_left(uint64_t x0, uint32_t x1) {
return (x0 << x1) | (x0 >> ((-x1) & 63));
}
static inline void core_ops_arith__i32__add_assign(int32_t *x0, int32_t *x1) {
*x0 = *x0 + *x1;
}
static inline uint8_t Eurydice_bitand_pv_u8(const uint8_t *p, uint8_t v) {
return (*p) & v;
}
static inline uint8_t Eurydice_shr_pv_u8(const uint8_t *p, int32_t v) {
return (*p) >> v;
}
static inline uint32_t Eurydice_min_u32(uint32_t x, uint32_t y) {
return x < y ? x : y;
}
static inline uint8_t
core_ops_bit__core__ops__bit__BitAnd_u8__u8__for__0__u8___bitand(
const uint8_t *x0, uint8_t x1) {
return Eurydice_bitand_pv_u8(x0, x1);
}
static inline uint8_t
core_ops_bit__core__ops__bit__Shr_i32__u8__for__0__u8___shr(const uint8_t *x0,
int32_t x1) {
return Eurydice_shr_pv_u8(x0, x1);
}
#define core_num_nonzero_private_NonZeroUsizeInner size_t
static inline core_num_nonzero_private_NonZeroUsizeInner
core_num_nonzero_private___core__clone__Clone_for_core__num__nonzero__private__NonZeroUsizeInner___clone(
core_num_nonzero_private_NonZeroUsizeInner *x0) {
return *x0;
}
#if defined(__cplusplus) && !defined(KRML_CXX17_COMPAT)
}
#endif
// ITERATORS
#define Eurydice_range_iter_next(iter_ptr, t, ret_t) \
(((iter_ptr)->start >= (iter_ptr)->end) \
? (KRML_CLITERAL(ret_t){EURYDICE_CFIELD(.tag =) 0, \
EURYDICE_CFIELD(.f0 =) 0}) \
: (KRML_CLITERAL(ret_t){EURYDICE_CFIELD(.tag =) 1, \
EURYDICE_CFIELD(.f0 =)(iter_ptr)->start++}))
#define core_iter_range__core__iter__traits__iterator__Iterator_A__for_core__ops__range__Range_A__TraitClause_0___next \
Eurydice_range_iter_next
// See note in karamel/lib/Inlining.ml if you change this
#define Eurydice_into_iter(x, t, _ret_t, _) (x)
#define core_iter_traits_collect__core__iter__traits__collect__IntoIterator_Clause1_Item__I__for_I__into_iter \
Eurydice_into_iter
// STRINGS
typedef char Eurydice_c_char_t;
typedef const Eurydice_c_char_t *Prims_string;
typedef void Eurydice_c_void_t;
// UNSAFE CODE
#define core_slice___Slice_T___as_mut_ptr(x, t, _) (x.ptr)
#define core_mem_size_of(t, _) (sizeof(t))
#define core_slice_raw_from_raw_parts_mut(ptr, len, _0, _1) \
(KRML_CLITERAL(Eurydice_slice){(void *)(ptr), len})
#define core_slice_raw_from_raw_parts(ptr, len, _0, _1) \
(KRML_CLITERAL(Eurydice_slice){(void *)(ptr), len})
// FIXME: add dedicated extraction to extract NonNull as T*
#define core_ptr_non_null_NonNull void *
// PRINTING
//
// This is temporary. Ultimately we want to be able to extract all of this.
typedef void *core_fmt_Formatter;
#define core_fmt_rt__core__fmt__rt__Argument__a___new_display(x1, x2, x3, x4) \
NULL
// BOXES
#ifndef EURYDICE_MALLOC
#define EURYDICE_MALLOC malloc
#endif
#ifndef EURYDICE_REALLOC
#define EURYDICE_REALLOC realloc
#endif
static inline char *malloc_and_init(size_t sz, char *init) {
char *ptr = (char *)EURYDICE_MALLOC(sz);
if (ptr != NULL)
memcpy(ptr, init, sz);
return ptr;
}
#define Eurydice_box_new(init, t, t_dst) \
((t_dst)(malloc_and_init(sizeof(t), (char *)(&init))))
// Initializer for array of size zero
#define Eurydice_empty_array(dummy, t, t_dst) ((t_dst){.data = {}})
#define Eurydice_box_new_array(len, ptr, t, t_dst) \
((t_dst)(malloc_and_init(len * sizeof(t), (char *)(ptr))))
// FIXME this needs to handle allocation failure errors, but this seems hard to
// do without evaluating malloc_and_init twice...
#define alloc_boxed__alloc__boxed__Box_T___try_new(init, t, t_ret) \
((t_ret){.tag = core_result_Ok, \
.f0 = (t *)malloc_and_init(sizeof(t), (char *)(&init))})
// VECTORS
// We adapt the layout of https://doc.rust-lang.org/std/vec/struct.Vec.html,
// dispensing with the nested RawVec -- basically, we follow what the
// documentation says. Just like Eurydice_slice, we keep sizes in number of
// elements. This means we pass three words by value whenever we carry a vector
// around. Things that modify the vector take &mut's in Rust, or a Eurydice_vec*
// in C.
//
// Another design choice: just like Eurydice_slice, we treat Eurydice_vec as an
// opaque type, and rely on macros receiving their type arguments at call-site
// to perform necessary casts. A downside is that anything that looks into the
// definition of Eurydice_vec must be exposed (from the eurydice point of view)
// as an external -- see, for instance, Eurydice_vec_failed, below.
typedef struct {
char *ptr;
size_t len; /* current length, in elements */
size_t capacity; /* the size of the allocation, in number of elements */
} Eurydice_vec, alloc_vec_Vec;
// This is a helper that Eurydice has special knowledge about. Essentially,
// allocation functions return a result type that has been monomorphized, say,
// Result_XY; this means we need to do something like:
// Eurydice_vec v = try_with_capacity(len, sz);
// Result_XY r = v.ptr == NULL ? (Result_XY) { .tag = core_result_Ok, .case_Ok
// = v }
// : (Result_XY) { .tag = core_result_Error, .case_Error = ... };
// but with a macro (since we don't have templates).
// However, unless we allow statement-expressions (GCC extension), we cannot do
// the above with an expression, since we need to name the result of
// try_with_capacity to avoid evaluating it twice.
static inline Eurydice_vec Eurydice_vec_alloc2(size_t len, size_t element_sz) {
return ((Eurydice_vec){.ptr = (char *)EURYDICE_MALLOC(len * element_sz),
.len = len,
.capacity = len});
}
#define Eurydice_vec_alloc(len, t, _) (Eurydice_vec_alloc2((len), sizeof(t)))
#define Eurydice_vec_overflows(len, t, _) (!((len) <= SIZE_MAX / (sizeof(t))))
#define Eurydice_vec_failed(v, _, _1) ((v).ptr == NULL)
#define Eurydice_layout(t, _) \
((core_alloc_layout_Layout){.size = sizeof(t), .align = _Alignof(t)})
#define alloc_vec__alloc__vec__Vec_T___resize( \
/* Eurydice_vec * */ v, /* size_t */ new_len, /* T */ elt, T, _0, _1) \
do { \
if (new_len <= (v)->capacity) \
(v)->len = new_len; \
else { \
(v)->ptr = EURYDICE_REALLOC((v)->ptr, new_len * sizeof(T)); \
/* TODO: check success? Rust function is infallible */ \
for (size_t i = (v)->len; i < new_len; i++) \
((T *)(v)->ptr)[i] = elt; \
(v)->len = new_len; \
(v)->capacity = new_len; \
} \
} while (0)
#define alloc_vec__alloc__vec__Vec_T___into_boxed_slice(/* Eurydice_vec */ v, \
T, _0, _1) \
((Eurydice_slice){.ptr = (v).ptr, .len = (v).len})
#define alloc_boxed__alloc__boxed__Box_T___from_raw(x, _0, _1) (x)
#define alloc_boxed__alloc__boxed__Box_T___into_raw(x, _0, _1) (x)
================================================
FILE: lib/AstOfLlbc.ml
================================================
(* C for Charon *)
module C = struct
include Charon.GAst
include Charon.LlbcAst
include Charon.Types
include Charon.TypesUtils
include Charon.Expressions
include Charon.Values
include Charon.GAstUtils
(* Fails if the variable is bound *)
let expect_free_var = function
| Free id -> id
| Bound _ -> failwith "Found unexpected bound variable"
let tsubst cgs ts ty =
begin
object
inherit [_] map_ty
method! visit_TVar _ v = TypeVarId.nth ts (expect_free_var v)
method! visit_CVar _ v = ConstGenericVarId.nth cgs (expect_free_var v)
method visit_'r _ x = x
end
end
#visit_ty
() ty
end
module LidMap = Krml.Idents.LidMap
module K = Krml.Ast
module L = Logging
open Krml.PrintAst.Ops
let fail fmt =
let b = Buffer.create 256 in
Printf.kbprintf (fun b -> failwith (Buffer.contents b)) b fmt
(** Environment *)
(* The various kinds of binders we insert in the expression scope. Usually come
in this order, the first three being only ever inserted upon entering a function
definition. *)
type var_id =
| TraitClauseMethod of {
clause_id : C.trait_ref_kind;
method_id : C.trait_method_id;
item_name : string;
pretty_name : string;
ts : K.type_scheme;
}
| TraitClauseConstant of {
clause_id : C.trait_ref_kind;
item_name : string;
pretty_name : string;
}
| ConstGenericVar of C.const_generic_var_id
| Var of C.local_id * C.ety (* the ety aids code-generation, sometimes *)
type env = {
(* Lookup functions to resolve various id's into actual declarations. *)
get_nth_function : C.FunDeclId.id -> C.fun_decl;
get_nth_type : C.TypeDeclId.id -> C.type_decl;
get_nth_global : C.GlobalDeclId.id -> C.global_decl;
get_nth_trait_impl : C.TraitImplId.id -> C.trait_impl;
get_nth_trait_decl : C.TraitDeclId.id -> C.trait_decl;
crate : C.crate;
(* Needed by the name matching logic *)
name_ctx : Charon.NameMatcher.ctx;
generic_params : C.generic_params;
(* We have three lists of binders, which allow us to go from a Rust variable
to a corresponding krml AST variable; everything is in De Bruijn, so
looking up a variable is essentially List.nth. To understand why we have
three lists here, we review the binding structure of the target (krml) AST.
The target AST has three binding scopes: cg vars, type vars and expression
vars. Type vars and type expressions are standard and have their own
scopes, and corresponding variable nodes (TBound for type variables, Bound
for expression variables). Const-generic variables are more complicted,
because they appear in *both* types and expressions; there is a *third*
scope of cg variables, with the following behavior:
- in types, CgVar and TCgArray contain DeBruijn indices referring to the cg
scope (standard), while
- in expressions, there is no ECgVar, so we repeat cg vars at the beginning
of the expression scope, and we rely on a regular EBound node to refer to
cg variables (trick). This trick avoids a combinatorial explosion of
substitution functions and makes sure all 60+ existing passes of krml do
*not* need to be aware of the addition of const-generics (except for
monomorphization, of course).
In short, the third scope for cg variables only applies for CgVar and
TCgArray; for expressions, cg variables masquerade as expression variables
and live as the first N variables of that scope.
To implement this, we rely on the corresponding three lists of binders,
with the additional caveat that push_cg_binder pushes in both cg_binders
and binders (see rationale above).
Example: fn f(x: [T; N]) -> usize { N }
Upon entering the body of f, we have:
- cg_binders: [ N, usize ]
- type_binders: [ T ]
- binders: [ `Cg (N, usize); `Clause (T: Copy, "copy"); `Var (x: [T; N]) ]
After translation, we get:
DFunction (..., 1 (* one type var *), 2 (* one cg var *), [
"N": TInt usize;
"x": TCgArray (TBound 0, 0); (* types use the cg scope *)
], EBound 2 (* expressions refer to the copy of the cg var as an expression var *)
*)
cg_binders : (C.const_generic_var_id * K.typ) list;
type_binders : C.type_var_id list;
binders : (var_id * K.typ) list;
(* For printing. *)
format_env : Charon.Print.fmt_env;
(* For picking pretty names *)
crate_name : string;
}
let debug env =
L.log "DebugEnv" "\n# Debug Env";
List.iteri
(fun i v ->
L.log "DebugEnv" "type_binders[%d]: %s\n" i (Charon.Print.type_var_id_to_pretty_string v))
env.type_binders
(* Environment: types *)
let findi p l =
let rec findi i l =
match l with
| hd :: tl ->
if p hd then
i, hd
else
findi (i + 1) tl
| [] -> raise Not_found
in
findi 0 l
let fst3 (x, _, _) = x
let snd3 (_, x, _) = x
let thd3 (_, _, x) = x
(* Suitable in types -- in expressions, use lookup_cg_in_expressions. *)
let lookup_cg_in_types env v1 =
let i, (_, t) = findi (fun (v2, _) -> v1 = v2) env.cg_binders in
i, t
let lookup_typ env (v1 : C.type_var_id) =
let i, _ = findi (( = ) v1) env.type_binders in
i
let push_type_binder env (t : C.type_param) =
{ env with type_binders = t.index :: env.type_binders }
let push_type_binders env (ts : C.type_param list) = List.fold_left push_type_binder env ts
(** Helpers: types *)
let with_any = K.(with_type TAny)
let is_dst_ref lid = Builtin.(lid = dst_ref_mut || lid = dst_ref_shared)
let assert_slice (t : K.typ) =
match t with
| TApp (lid, [ t; u ]) when is_dst_ref lid && u = TInt SizeT -> t
| _ -> fail "Not a slice: %a" ptyp t
let string_of_path_elem (env : env) (p : Charon.Types.path_elem) : string =
Charon.Print.path_elem_to_string env.format_env p
let string_of_name env ps = String.concat "::" (List.map (string_of_path_elem env) ps)
let mk_field_name f i =
match f with
| Some f -> f
| None -> "f" ^ string_of_int i
let is_enum (env : env) (id : C.type_decl_id) : bool =
let decl = env.get_nth_type id in
match decl.C.kind with
| Enum branches -> List.for_all (fun v -> v.C.fields = []) branches
| _ -> false
let mk_enum_case lid c = fst lid @ [ snd lid ], c
(* Helpers: traits finding & matching *)
module RustNames = struct
open Charon.NameMatcher
let config =
{
map_vars_to_vars = false;
match_with_trait_decl_refs = true;
(* use_trait_decl_refs = true; *)
}
let vec = parse_pattern "alloc::vec::Vec<@>"
let range = parse_pattern "core::ops::range::Range<@>"
let option = parse_pattern "core::option::Option<@>"
(* Just to have a uniform view of the table of distinguished declarations *)
let builtin_of_function decl : Builtin.builtin =
match decl with
| Krml.Ast.DFunction (_, _, n_cgs, n_type_args, ret_t, name, binders, _) ->
if n_cgs > List.length binders then
Krml.Warn.fatal_error "n_cgs=%d, but List.length binders=%d for %a\n" n_cgs
(List.length binders) Krml.PrintAst.Ops.plid name;
let cg_args, rest = Krml.KList.split n_cgs binders in
{
name;
typ = Krml.Helpers.fold_arrow (List.map (fun (x : Krml.Ast.binder) -> x.typ) rest) ret_t;
n_type_args;
cg_args = List.map (fun (x : Krml.Ast.binder) -> x.typ) cg_args;
arg_names = List.map (fun (x : Krml.Ast.binder) -> x.node.name) rest;
}
| _ -> failwith "impossible"
let known_builtins no_const =
let ( || ) no_const_variant default =
if no_const then
no_const_variant
else
default
in
[
(* slices *)
parse_pattern "SliceIndexShared<'_, @T>", Builtin.(slice_index_mut || slice_index_shared);
parse_pattern "SliceIndexMut<'_, @T>", Builtin.slice_index_mut;
parse_pattern "core::slice::index::{core::ops::index::Index<[@T], @I, @Clause2_Output>}::index<'_, @, core::ops::range::Range, [@]>", builtin_of_function Builtin.(slice_subslice_func_mut || slice_subslice_func_shared);
parse_pattern "core::slice::index::{core::ops::index::IndexMut<[@T], @I, @Clause2_Output>}::index_mut<'_, @, core::ops::range::Range, [@]>", builtin_of_function Builtin.slice_subslice_func_mut;
parse_pattern "core::slice::index::{core::ops::index::Index<[@T], @I, @Clause2_Output>}::index<'_, @, core::ops::range::RangeTo, [@]>", builtin_of_function Builtin.(slice_subslice_to_func_mut || slice_subslice_to_func_shared);
parse_pattern "core::slice::index::{core::ops::index::IndexMut<[@T], @I, @Clause2_Output>}::index_mut<'_, @, core::ops::range::RangeTo, [@]>", builtin_of_function Builtin.slice_subslice_to_func_mut;
parse_pattern "core::slice::index::{core::ops::index::Index<[@T], @I, @Clause2_Output>}::index<'_, @, core::ops::range::RangeFrom, [@]>", builtin_of_function Builtin.(slice_subslice_from_func_mut || slice_subslice_from_func_shared);
parse_pattern "core::slice::index::{core::ops::index::IndexMut<[@T], @I, @Clause2_Output>}::index_mut<'_, @, core::ops::range::RangeFrom, [@]>", builtin_of_function Builtin.slice_subslice_from_func_mut;
(* arrays *)
parse_pattern "core::array::{core::ops::index::Index<[@T; @N], @I, @Clause2_Clause0_Output>}::index<'_, @, core::ops::range::Range, [@], @>", builtin_of_function Builtin.(array_to_subslice_func_mut || array_to_subslice_func_shared);
parse_pattern "core::array::{core::ops::index::IndexMut<[@T; @N], @I, @Clause2_Clause0_Output>}::index_mut<'_, @, core::ops::range::Range, [@], @>", builtin_of_function Builtin.array_to_subslice_func_mut;
parse_pattern "core::array::{core::ops::index::Index<[@T; @N], @I, @Clause2_Clause0_Output>}::index<'_, @, core::ops::range::RangeTo, [@], @>", builtin_of_function Builtin.(array_to_subslice_to_func_mut || array_to_subslice_to_func_shared);
parse_pattern "core::array::{core::ops::index::IndexMut<[@T; @N], @I, @Clause2_Clause0_Output>}::index_mut<'_, @, core::ops::range::RangeTo, [@], @>", builtin_of_function Builtin.array_to_subslice_to_func_mut;
parse_pattern "core::array::{core::ops::index::Index<[@T; @N], @I, @Clause2_Clause0_Output>}::index<'_, @, core::ops::range::RangeFrom, [@], @>", builtin_of_function Builtin.(array_to_subslice_from_func_mut || array_to_subslice_from_func_shared);
parse_pattern "core::array::{core::ops::index::IndexMut<[@T; @N], @I, @Clause2_Clause0_Output>}::index_mut<'_, @, core::ops::range::RangeFrom, [@], @>", builtin_of_function Builtin.array_to_subslice_from_func_mut;
(* slices <-> arrays *)
parse_pattern "ArrayToSliceShared<'_, @T, @N>", builtin_of_function Builtin.(array_to_slice_func_mut || array_to_slice_func_shared);
parse_pattern "ArrayToSliceMut<'_, @T, @N>", builtin_of_function Builtin.array_to_slice_func_mut;
parse_pattern "core::convert::{core::convert::TryInto<@T, @U, @Clause2_Error>}::try_into<&'_ [@T], [@T; @], core::array::TryFromSliceError>", Builtin.slice_to_array;
parse_pattern "core::convert::{core::convert::TryInto<@T, @U, @Clause2_Error>}::try_into<&'_ mut [@T], [@T; @], core::array::TryFromSliceError>", Builtin.slice_to_array;
parse_pattern "core::convert::{core::convert::TryInto<@T, @U, @Clause2_Error>}::try_into<&'_ [@T], &'_ [@T; @], core::array::TryFromSliceError>", Builtin.slice_to_ref_array;
parse_pattern "core::convert::{core::convert::TryInto<@T, @U, @Clause2_Error>}::try_into<&'_ mut [@T], &'_ mut [@T; @], core::array::TryFromSliceError>", Builtin.slice_to_ref_array;
(* bitwise & arithmetic operations *)
parse_pattern "core::ops::bit::BitAnd<&'_ u8, u8>::bitand", Builtin.bitand_pv_u8;
parse_pattern "core::ops::bit::Shr<&'_ u8, i32>::shr", Builtin.shr_pv_u8;
(* misc *)
parse_pattern "core::cmp::Ord::min", Builtin.min_u32;
(* boxes *)
parse_pattern "alloc::boxed::{alloc::boxed::Box<@T>}::new<@>", Builtin.box_new;
]
[@ocamlformat "disable"]
let from_u16 = parse_pattern "core::convert::From::from"
let from_u32 = parse_pattern "core::convert::From::from"
let from_u64 = parse_pattern "core::convert::From::from"
let from_u128 = parse_pattern "core::convert::From::from"
let from_i16 = parse_pattern "core::convert::From::from"
let from_i32 = parse_pattern "core::convert::From::from"
let from_i64 = parse_pattern "core::convert::From::from"
let from_i128 = parse_pattern "core::convert::From::from"
let from = parse_pattern "core::convert::From<@T, @U>::from"
let into_u16 = parse_pattern "core::convert::Into<@U, u16>::into"
let into_u32 = parse_pattern "core::convert::Into<@U, u32>::into"
let into_u64 = parse_pattern "core::convert::Into<@U, u64>::into"
let into_u128 = parse_pattern "core::convert::Into<@U, u128>::into"
let into_i16 = parse_pattern "core::convert::Into<@U, i16>::into"
let into_i32 = parse_pattern "core::convert::Into<@U, i32>::into"
let into_i64 = parse_pattern "core::convert::Into<@U, i64>::into"
let into_i128 = parse_pattern "core::convert::Into<@U, i128>::into"
let into = parse_pattern "core::convert::Into<@U, @T>::into"
let is_vec env = match_pattern_with_type_id env.name_ctx config (mk_empty_maps ()) vec
let is_range env = match_pattern_with_type_id env.name_ctx config (mk_empty_maps ()) range
let is_option env = match_pattern_with_type_id env.name_ctx config (mk_empty_maps ()) option
end
let string_of_pattern pattern = Charon.NameMatcher.(pattern_to_string { tgt = TkPattern } pattern)
let pattern_of_fn_ptr env fn_ptr =
Charon.NameMatcher.(
fn_ptr_to_pattern env.name_ctx
{ tgt = TkPattern; use_trait_decl_refs = true }
Charon.TypesUtils.empty_generic_params fn_ptr)
let pattern_of_name env name =
Charon.NameMatcher.(
name_to_pattern env.name_ctx { tgt = TkPattern; use_trait_decl_refs = true } name)
let string_of_fn_ptr env fn_ptr = string_of_pattern (pattern_of_fn_ptr env fn_ptr)
(** Translation of types *)
let lid_of_name (env : env) (name : Charon.Types.name) : K.lident =
let prefix, name = Krml.KList.split_at_last name in
List.map (string_of_path_elem env) prefix, string_of_path_elem env name
let width_of_integer_type (t : Charon.Types.integer_type) : K.width =
match t with
| Signed Isize -> PtrdiffT
| Signed I8 -> Int8
| Signed I16 -> Int16
| Signed I32 -> Int32
| Signed I64 -> Int64
| Signed I128 ->
failwith "Internal error: `i128` should not be handled in `width_of_integer_type`."
| Unsigned Usize -> SizeT
| Unsigned U8 -> UInt8
| Unsigned U16 -> UInt16
| Unsigned U32 -> UInt32
| Unsigned U64 -> UInt64
| Unsigned U128 ->
failwith "Internal error: `u128` should not be handled in `width_of_integer_type`."
let lid_of_type_decl_id (env : env) (id : C.type_decl_id) =
let { C.item_meta; _ } = env.get_nth_type id in
lid_of_name env item_meta.name
let constant_of_scalar_value sv =
let w = width_of_integer_type (Charon.Scalars.get_ty sv) in
w, Z.to_string (Charon.Scalars.get_val sv)
let assert_cg_scalar : C.constant_expr -> C.scalar_value = function
| { kind = C.CLiteral (VScalar n); _ } -> n
| cg -> failwith ("Unsupported: non-constant const generic: " ^ C.show_constant_expr cg)
let cg_of_const_generic env (cg : C.constant_expr) =
match cg.kind with
| C.CVar var -> K.CgVar (fst (lookup_cg_in_types env (C.expect_free_var var)))
| C.CLiteral (VScalar sv) -> CgConst (constant_of_scalar_value sv)
| _ -> failwith ("cg_of_const_generic: " ^ Charon.Print.constant_expr_to_string env.format_env cg)
let float_width float_ty : K.width =
match float_ty with
| C.F32 -> Float32
| C.F64 -> Float64
| C.F16 | C.F128 -> failwith "TODO: f16 & f128 are not supported."
let typ_of_literal_ty (_env : env) (ty : Charon.Types.literal_type) : K.typ =
match ty with
| TBool -> K.TBool
| TChar -> Builtin.char_t
| TFloat f -> K.TInt (float_width f)
| TInt C.I128 -> Builtin.int128_t
| TUInt C.U128 -> Builtin.uint128_t
| _ -> K.TInt (width_of_integer_type (Charon.TypesUtils.literal_as_integer ty))
let const_of_ref_kind kind =
if !Options.no_const then
false
else
match kind with
| C.RMut -> false
| C.RShared -> true
let const_of_borrow_kind bk =
if !Options.no_const then
false
else
match bk with
| C.BShared -> true
| C.BShallow -> true
| _ -> false
let const_of_tbuf b =
if !Options.no_const then
false
else
match b with
| K.TBuf (_, const) -> const
| _ -> failwith "not a tbuf"
(* e: Eurydice_dst *)
let mk_dst_deref _env t e =
(* ptr_field: t* *)
(* XXX need proper const here *)
let ptr_field = K.(with_type (TBuf (t, true)) (EField (e, "ptr"))) in
K.(with_type t (EBufRead (ptr_field, Krml.Helpers.zero_usize)))
let ensure_named i name =
match name, i with
| None, 0 -> "fst"
| None, 1 -> "snd"
| None, 2 -> "thd"
| None, _ -> Printf.sprintf "field%d" i
| Some name, _ -> name
let lookup_field env typ_id field_id =
let ty_decl = env.get_nth_type typ_id in
let fields =
match ty_decl.kind with
| Struct fields -> fields
| _ -> failwith "not a struct"
in
let i = C.FieldId.to_int field_id in
let field = List.nth fields i in
ensure_named i field.field_name
let mk_expr_arr_struct (expr_array : K.expr) = K.EFlat [ Some "data", expr_array ]
(** A vtable type is actually just a struct type, this function takes out the hinted ID of the
vtable struct from the dynamic predicate and then translate it, returns a reference to the
struct type itself.
Notably, a dynamic predicate is of the form:
[dyn Trait + AutoTraits + 'a]. Namely, it has the arguments to the
unique non-auto trait and the assignments to each associated types as the **principal trait**
[Trait<...>], and then some additional auto-traits having no methods and finally a region
constraint. Here we care only about the principal trait. *)
let rec vtable_typ_of_dyn_pred (env : env) (pred : C.dyn_predicate) : K.typ =
let binder_params = pred.binder.binder_params in
match binder_params.trait_clauses with
| [] -> failwith "DynTrait has empty clause! Please report this to Charon."
(* As guaranteed by Rustc and hence Charon, the first clause must be the principal trait *)
| principal_clause :: _ -> (
let tref = principal_clause.trait in
let decl = env.get_nth_trait_decl tref.binder_value.id in
match decl.vtable with
| None ->
failwith "Fetching vtable from a trait without vtable! Please report this to Charon."
| Some ty_ref ->
(* The ty_ref here is of the form: `{vtable}` *)
(* Hence we need to firstly substitute `TraitParams` with the actual types provided by the dynamic predicate's `TraitArgs` *)
(* And then substitute `AssocTys` with the actual types provided by the dynamic predicate's assignments to these associated types *)
(* The trait ref is guaranteed to be with empty binding values in the principal clause *)
(* Yet, we will need to move shift the internal DeBruijn indices with `extract_from_binder` *)
let tref = Charon.Substitute.(extract_from_binder trait_decl_ref_substitute tref) in
(* First step: get the `TraitArgs` *)
let base_args =
let generics = tref.generics in
{ generics with types = List.tl generics.types }
in
(* Second step: find from the assignments of assoc tys *)
let assoc_tys =
let base_removal = fun l -> snd (Krml.KList.split (List.length base_args.types) l) in
let find_assoc_ty_arg = function
| C.TTraitType (tref, name) ->
(* We match by the trait-ID and the assoc-ty name, which should be unique *)
let target_id = tref.trait_decl_ref.binder_value.id in
let assoc_ty_assns = binder_params.trait_type_constraints in
let finder (binded_assn : C.trait_type_constraint C.region_binder) =
let assn =
Charon.Substitute.(
extract_from_binder trait_type_constraint_substitute binded_assn)
in
if
assn.trait_ref.trait_decl_ref.binder_value.id = target_id
&& assn.type_name = name
then
Some assn.ty
else
None
in
begin
match List.find_map finder assoc_ty_assns with
| Some ty -> ty
| None ->
fail "Could not find associated type assignment for associated type %s" name
end
| _ ->
failwith
"This should not happen: the rest of the generic types in a vtable-ref in a \
trait-decl should all be referring to associated types."
in
ty_ref.generics.types
(* Remove the base param types from it, leaving the associated types params *)
|> base_removal
(* For each assoc type param, find the corresponding arg from the dyn predicate *)
|> List.map find_assoc_ty_arg
in
let args = { base_args with types = base_args.types @ assoc_tys } in
let ty_args_ref = { ty_ref with generics = args } in
typ_of_ty env (C.TAdt ty_args_ref))
(* This functions takes a Charon type, and returns the associated metadata as a krml type,
or None if there is no metadata *)
and metadata_typ_of_ty (env : env) (ty : Charon.Types.ty) : K.typ option =
match ty with
| C.TAdt ty_decl_ref -> begin
match ty_decl_ref.id with
| C.TAdtId decl_id -> begin
let decl = env.get_nth_type decl_id in
match decl.ptr_metadata with
| C.NoMetadata -> None
| C.Length -> Some Krml.Helpers.usize
| C.VTable ty_ref ->
let ty_ref = { ty_ref with generics = ty_decl_ref.generics } in
Some (K.TBuf (typ_of_ty env (C.TAdt ty_ref), false))
| C.InheritFrom (C.TVar (C.Free var)) ->
let ty = List.nth ty_decl_ref.generics.types (C.TypeVarId.to_int var) in
metadata_typ_of_ty env ty
| C.InheritFrom _ ->
failwith
"Eurydice does not handle PtrMetadata inheritance, please consider using \
monomorphized LLBC"
end
| C.TTuple -> begin
match List.rev @@ ty_decl_ref.generics.types with
(* Empty metadata for empty tuple *)
| [] -> None
(* For tuple, the type of metadata is the last element *)
| last :: _ -> metadata_typ_of_ty env last
end
| C.TBuiltin C.TBox -> None
| C.TBuiltin C.TStr -> Some Krml.Helpers.usize
end
| C.TArray _ -> None
| C.TSlice _ -> Some Krml.Helpers.usize
| C.TVar _ ->
(* TEMPORARY: this needs to be enabled once the monomorphization PR lands --
for now, there are still polymorphic type definitions of the form type
Foo = ... in the AST (those will be monomorphized away, eventually) *)
let _var_is_sized (clause : C.trait_param) =
let trait = clause.trait.binder_value in
match trait.generics.types with
| [] -> failwith "Unexpected empty `Self` from trait clause."
(* The variable here in C.TVar should be free variable, hence no need to adjust the DB id. *)
| self :: _ ->
self = ty
&&
let decl = env.get_nth_trait_decl trait.id in
(* It has the Sized marker, which is of lang_item "sized" *)
decl.item_meta.lang_item = Some "sized"
in
let var_is_sized =
true
(*List.exists var_is_sized env.generic_params.trait_clauses*)
in
if var_is_sized then
None
else
failwith
"Eurydice does not handle taking metadata from non-Sized type vars, please consider \
using monomorphized LLBC."
| C.TTraitType (_, _) ->
failwith
"Eurydice does not handle taking metadata from assoc types, please consider using \
monomorphized LLBC."
(* The metadata of a &dyn Trait object is a pointer to its vtable *)
| C.TDynTrait pred -> Some (K.TBuf (vtable_typ_of_dyn_pred env pred, false))
| C.TLiteral _ | C.TRef (_, _, _) | C.TRawPtr (_, _) | C.TFnPtr _ | C.TFnDef _ -> None
(* The metadata must not have ptr metadata as they must be Sized. *)
| C.TPtrMetadata _ -> None
| C.TNever | C.TError _ -> failwith "Error types to fetch metadata"
(* Translate Charon type &T as a krml type -- this handles special cases
where address-taking in Rust creates a DST, which we represent as instances
of the dst_ref type. There are many such cases: slices, &str, etc. *)
and ptr_typ_of_ty (env : env) ~const (ty : Charon.Types.ty) : K.typ =
(* Handle special cases first *)
match ty with
(* Special case to handle slice : &[T] *)
| TSlice t -> Builtin.mk_slice ~const (typ_of_ty env t)
(* Special case to handle &str *)
| TAdt { id = TBuiltin TStr; _ } -> Builtin.str_t ~const
(* Special case to handle DynTrait *)
| TDynTrait pred ->
Builtin.mk_dst_ref ~const Builtin.c_void_t (K.TBuf (vtable_typ_of_dyn_pred env pred, false))
(* General case, all &T is turned to either thin T* or fat Eurydice::DstRef *)
| _ -> (
let typ = typ_of_ty env ty in
match metadata_typ_of_ty env ty with
| None -> K.TBuf (typ, const)
| Some meta -> Builtin.mk_dst_ref ~const typ meta)
and typ_of_ty (env : env) (ty : Charon.Types.ty) : K.typ =
match ty with
| TVar var -> K.TBound (lookup_typ env (C.expect_free_var var))
| TLiteral t -> typ_of_literal_ty env t
| TNever -> failwith "Impossible: Never"
| TDynTrait _ -> failwith "TODO: dyn Trait"
| TAdt { id = TBuiltin TBox; generics = { types = [ t ]; _ } } -> ptr_typ_of_ty ~const:false env t
| TRef (_, t, rk) | TRawPtr (t, rk) ->
let const = const_of_ref_kind rk in
ptr_typ_of_ty env ~const t
| TAdt { id; generics = { types = [ t ]; _ } as generics } when RustNames.is_vec env id generics
-> Builtin.mk_vec (typ_of_ty env t)
| TAdt { id = TAdtId id; generics = { types = args; const_generics = generic_args; _ } } ->
let ts = List.map (typ_of_ty env) args in
let cgs = List.map (cg_of_const_generic env) generic_args in
let lid = lid_of_type_decl_id env id in
K.fold_tapp (lid, ts, cgs)
| TAdt { id = TTuple; generics = { types = args; const_generics; _ } } ->
assert (const_generics = []);
begin
match args with
| [] -> TUnit
| [ t ] -> typ_of_ty env t (* charon issue #205 *)
| _ -> TTuple (List.map (typ_of_ty env) args)
end
| TArray (t, cg) -> typ_of_struct_arr env t cg
| TSlice t ->
(* Appears in instantiations of patterns and generics, so we translate it to a placeholder. *)
TApp (Builtin.derefed_slice, [ typ_of_ty env t ])
| TAdt { id = TBuiltin TStr; generics = { types = []; _ } } -> Builtin.deref_str_t
| TAdt { id = TBuiltin f; generics = { types = args; const_generics; _ } } ->
List.iter (fun x -> print_endline (C.show_constant_expr x)) const_generics;
fail "TODO: Adt/Builtin %s (%d) %d " (C.show_builtin_ty f) (List.length args)
(List.length const_generics)
| TTraitType _ -> failwith ("TODO: TraitTypes " ^ Charon.Print.ty_to_string env.format_env ty)
| TFnPtr fn_sig ->
let { C.inputs = ts; output = t; _ } = fn_sig.binder_value in
let typs = List.map (typ_of_ty env) ts in
let typs =
match typs with
| [] -> [ K.TUnit ]
| typs -> typs
in
begin
match typ_of_ty env t with
| TArrow _ ->
failwith
"Function pointer `fn` currying is not supported, consider using `&'static dyn Fn` \
instead."
| typ -> Krml.Helpers.fold_arrow typs typ
end
| TFnDef bound_fn_ref -> begin
match Charon.Substitute.lookup_fndef_sig env.crate bound_fn_ref with
| None -> failwith "Missing function declaration"
| Some fn_sig -> typ_of_ty env (TFnPtr fn_sig)
end
| TPtrMetadata _ ->
failwith
"The type-level computation `PtrMetadata(t)` should be handled by Charon, consider using \
monomorphised LLBC."
| TError _ -> failwith "Found type error in charon's output"
and typ_of_struct_arr (env : env) (t : C.ty) (cg : C.constant_expr) : K.typ =
let typ_t = typ_of_ty env t in
let cg = cg_of_const_generic env cg in
Builtin.mk_arr typ_t cg
let maybe_cg_array (env : env) (t : C.ty) (cg : C.constant_expr) =
match cg.kind with
| CLiteral _ -> K.TArray (typ_of_ty env t, constant_of_scalar_value (assert_cg_scalar cg))
| CVar var ->
let id, cg_t = lookup_cg_in_types env (C.expect_free_var var) in
assert (cg_t = K.TInt SizeT);
K.TCgArray (typ_of_ty env t, id)
| _ -> failwith "TODO: CgGlobal"
(* Environment: expressions *)
let is_var v2 v1 =
match v2 with
| Var (v2, _) -> v2 = v1
| _ -> false
let assert_var = function
| Var (v2, ty) -> v2, ty
| _ -> assert false
let assert_trait_clause_method = function
| TraitClauseMethod { ts; _ } -> ts
| _ -> assert false
(* Regular binders *)
let lookup env v1 =
let i, (_, t) = findi (fun (v2, _) -> is_var v2 v1) env.binders in
i, t
let lookup_with_original_type env v1 =
let i, (v, t) = findi (fun (v2, _) -> is_var v2 v1) env.binders in
let _, ty = assert_var v in
i, t, ty
(* Const generic binders *)
let push_cg_binder env (t : C.const_generic_param) =
{
env with
cg_binders = (t.index, typ_of_ty env t.ty) :: env.cg_binders;
binders = (ConstGenericVar t.index, typ_of_ty env t.ty) :: env.binders;
}
let push_cg_binders env (ts : C.const_generic_param list) = List.fold_left push_cg_binder env ts
let push_binder env (t : C.local) =
{ env with binders = (Var (t.index, t.local_ty), typ_of_ty env t.local_ty) :: env.binders }
let push_binders env (ts : C.local list) = List.fold_left push_binder env ts
(* Clause binders, which only appear as function parameters, and hold an unknown
trait method (dictionary-style). *)
let push_clause_binder env b = { env with binders = b :: env.binders }
let push_clause_binders env bs = List.fold_left push_clause_binder env bs
let lookup_clause_method env clause_id method_id =
let i, (v, t) =
try
findi
(function
| TraitClauseMethod { clause_id = clause_id2; method_id = method_id2; _ }, _ ->
clause_id2 = clause_id && method_id2 = method_id
| _ -> false)
env.binders
with Not_found ->
Krml.KPrint.bprintf "Error looking up %s.%s\n" (C.show_trait_ref_kind clause_id)
(C.show_trait_method_id method_id);
raise Not_found
in
i, t, assert_trait_clause_method v
let lookup_clause_constant env clause_id item_name =
let i, (_, t) =
try
findi
(function
| TraitClauseConstant { clause_id = clause_id2; item_name = item_name2; _ }, _ ->
clause_id2 = clause_id && item_name2 = item_name
| _ -> false)
env.binders
with Not_found ->
Krml.KPrint.bprintf "Error looking up %s.%s\n" (C.show_trait_ref_kind clause_id) item_name;
raise Not_found
in
i, t
(** Translation of expressions (statements, operands, rvalues, places) *)
let uu =
let r = ref 0 in
fun () ->
let suffix = string_of_int !r in
incr r;
"uu____" ^ suffix
let binder_of_var (env : env) (l : C.local) : K.binder =
let name = Option.value ~default:(uu ()) l.name in
let meta =
match name with
| "left_val" | "right_val" -> [ K.AttemptInline ]
| _ -> []
in
let binder = Krml.Helpers.fresh_binder ~mut:true name (typ_of_ty env l.local_ty) in
{ binder with node = { binder.node with meta = meta @ binder.node.meta } }
let find_nth_variant (env : env) (typ : C.type_decl_id) (var : C.variant_id) =
match env.get_nth_type typ with
| { kind = Enum variants; _ } -> Charon.Types.VariantId.nth variants var
| _ -> failwith "impossible: type is not a variant"
let rec with_locals (env : env) (t : K.typ) (locals : C.local list) (k : env -> 'a) : 'a =
match locals with
| [] -> k env
| l :: locals ->
let env = push_binder env l in
let b = binder_of_var env l in
K.(with_type t (ELet (b, Krml.Helpers.any, with_locals env t locals k)))
let lookup_cg_in_expressions (env : env) (v1 : C.const_generic_var_id) =
let i, (_, t) = findi (fun (v2, _) -> v2 = ConstGenericVar v1) env.binders in
i, t
let expression_of_cg_var_id env v =
let i, t = lookup_cg_in_expressions env v in
K.(with_type t (EBound i))
let expression_of_var_id (env : env) (v : C.local_id) : K.expr =
let i, t = lookup env v in
K.(with_type t (EBound i))
(** Assume here the maximum length is 128-bit -- will throw away the larger if larger. This is a
helper function to split a 128-bit integer into two 64-bit integers and is not assumed to be
used in other contexts. Returns the **expr** pair (high64bits, low64bits) *)
let split_128bit (value : Z.t) =
let mask128 = Z.sub (Z.shift_left Z.one 128) Z.one in
let mask64 = Z.sub (Z.shift_left Z.one 64) Z.one in
(* Always truncate to 128 bits using bitwise AND *)
let value = Z.logand value mask128 in
(* Extract low 64 bits *)
let low64 = Z.logand mask64 value in
(* Shift right without sign extension (use logical shift) *)
let high64 = Z.shift_right value 64 in
let to_expr_u64bits v =
let print_Z z = Z.format "%#x" z in
K.with_type (K.TInt UInt64) @@ K.EConstant (UInt64, print_Z v)
in
to_expr_u64bits high64, to_expr_u64bits low64
let expression_of_int128_t (value : Z.t) =
let i128_max = Z.sub (Z.shift_left Z.one 127) Z.one in
if value > i128_max then
failwith "value is larger than the maximum value of i128";
let i128_min = Z.neg (Z.shift_left Z.one 127) in
if value < i128_min then
failwith "value is smaller than the minimum value of i128";
let high64, low64 = split_128bit value in
K.(with_type Builtin.int128_t (EApp (Builtin.(get_128_op ("i", "from_bits")), [ high64; low64 ])))
let expression_of_uint128_t (value : Z.t) =
let u128_max = Z.sub (Z.shift_left Z.one 128) Z.one in
if value > u128_max then
failwith "value is larger than the maximum value of u128";
let high64, low64 = split_128bit value in
K.(
with_type Builtin.uint128_t (EApp (Builtin.(get_128_op ("u", "from_bits")), [ high64; low64 ])))
let expression_of_scalar_value sv : K.expr =
let int_ty = Charon.Scalars.get_ty sv in
let value = Charon.Scalars.get_val sv in
match int_ty with
| C.Signed C.I128 -> expression_of_int128_t value
| C.Unsigned C.U128 -> expression_of_uint128_t value
| _ ->
let w = width_of_integer_type int_ty in
K.(with_type (TInt w) (EConstant (constant_of_scalar_value sv)))
let expression_of_literal (_env : env) (l : C.literal) : K.expr =
match l with
| VScalar sv -> expression_of_scalar_value sv
| VBool b -> K.(with_type TBool (EBool b))
| VStr s ->
let ascii = Utf8.ascii_of_utf8_str s in
let len = String.length s in
K.(
with_type (Builtin.str_t ~const:true)
(EFlat
[
Some "ptr", with_type Krml.Checker.c_string (EString ascii);
Some "meta", with_type Krml.Helpers.usize (EConstant (SizeT, string_of_int len));
]))
| VChar c -> K.(with_type Builtin.char_t (EConstant (UInt32, string_of_int @@ Uchar.to_int c)))
| VByteStr lst ->
let str = List.map (Printf.sprintf "%#x") lst |> String.concat "" in
K.(with_type Krml.Checker.c_string (EString str))
| VFloat { C.float_ty; float_value } ->
let w = float_width float_ty in
K.(with_type (TInt w) (EConstant (w, float_value)))
let expression_of_const_generic env (cg : C.constant_expr) =
match cg.kind with
| C.CGlobal _ -> failwith "TODO: CgGLobal"
| C.CVar var -> expression_of_cg_var_id env (C.expect_free_var var)
| C.CLiteral l -> expression_of_literal env l
| _ -> failwith "TODO: CgExpr"
let has_unresolved_generic (ty : K.typ) : bool =
(object
inherit [_] Krml.Ast.reduce
method zero = false
method plus = ( || )
method! visit_TBound _ _ = true
end)
#visit_typ
false ty
let rec expression_of_place (env : env) (p : C.place) : K.expr =
(* We construct a target expression. Callers may still use the original type to tell arrays
and references apart, since their *uses* (e.g. addr-of) compile in a type-directed way based on
the *original* rust type *)
match p.kind with
| PlaceLocal var_id ->
let i, t = lookup env var_id in
K.(with_type t (EBound i))
| PlaceGlobal { id; _ } ->
let global = env.get_nth_global id in
K.with_type (typ_of_ty env p.ty) (K.EQualified (lid_of_name env global.item_meta.name))
| PlaceProjection (sub_place, PtrMetadata) -> begin
let e = expression_of_place env sub_place in
match e.typ with
| TApp (lid, [ _; meta_ty ]) when is_dst_ref lid ->
(* XXX need to adjust *)
K.(with_type meta_ty (EField (e, "meta")))
(* In cases like `PtrMetadata(T)` when `T` is a type variable or some types with unresolved type variable,
We cannot tell the correct metadata type from it until fully monomorphized.
But we can surely rely on monomorphized LLBC, and we ignore handling such cases in Eurydice. *)
| ty when has_unresolved_generic ty ->
failwith
"Eurydice do not handle ptr-metadata for generic types. Consider using monomorphized \
LLBC."
(* Otherwise, fetching ptr-metadata from a non-DST simply results in `()`
When a type is fully resolved and it is not `Eurydice::DstRef`, we can be confident that it is not a DST. *)
| _ -> K.with_type TUnit K.EUnit
end
| PlaceProjection (sub_place, pe) -> begin
(* Can't evaluate this here because of the special case for DSTs. *)
let sub_e = lazy (expression_of_place env sub_place) in
let ( !* ) = Lazy.force in
(* L.log "AstOfLlbc" "e=%a\nty=%s\npe=%s\n" pexpr sub_e (C.show_ty sub_place.ty) *)
(* (C.show_projection_elem pe); *)
match pe, sub_place, sub_place.ty with
(* slices simply cannot be dereferenced into places which have unknown size.
They are supposed to be reborrowed again directly after the deref which is handled in expression_of_rvalue *)
| C.Deref, _, TRef (_, TSlice _, _) | C.Deref, _, TRawPtr (TSlice _, _) -> assert false
| ( C.Deref,
_,
(TRawPtr _ | TRef _ | TAdt { id = TBuiltin TBox; generics = { types = [ _ ]; _ } }) ) ->
(* All types represented as a pointer at run-time, compiled to a C pointer *)
begin
match !*sub_e.K.typ with
| TBuf (t_pointee, _) ->
let const =
match sub_place.ty with
| TRef (_, _, k) -> const_of_ref_kind k
| _ -> false
in
Krml.Helpers.(mk_deref ~const t_pointee !*sub_e.K.node)
| t ->
L.log "AstOfLlbc" "UNHANDLED DEREFERENCE\ne=%a\nt=%a\nty=%s\npe=%s\n" pexpr !*sub_e
ptyp t (C.show_ty sub_place.ty) (C.show_projection_elem pe);
failwith "unhandled dereference"
end
| ( Field (ProjAdt (typ_id, None), field_id),
{ kind = PlaceProjection (sub_place, C.Deref); _ },
C.TAdt _ ) ->
let field_name = lookup_field env typ_id field_id in
let sub_e = expression_of_place env sub_place in
let place_typ = typ_of_ty env p.ty in
let const =
match sub_place.ty with
| TRef (_, _, k) -> const_of_ref_kind k
| _ -> false
in
begin
match sub_e.K.typ with
| K.TApp (dst_ref_hd, [ dst_t; _meta ]) when is_dst_ref dst_ref_hd ->
(* getting field from a fat pointer of DST *)
(* XXX need to adjust *)
K.with_type place_typ (K.EField (mk_dst_deref env dst_t sub_e, field_name))
| _ ->
(* Same as below *)
K.with_type place_typ
(K.EField
( Krml.Helpers.(
mk_deref ~const
(Krml.Helpers.assert_tbuf_or_tarray sub_e.K.typ)
sub_e.K.node),
field_name ))
end
| Field (ProjAdt (typ_id, variant_id), field_id), _, C.TAdt _ -> begin
let place_typ = typ_of_ty env p.ty in
match variant_id with
| None ->
let field_name = lookup_field env typ_id field_id in
K.with_type place_typ (K.EField (!*sub_e, field_name))
| Some variant_id ->
let variant = find_nth_variant env typ_id variant_id in
let field_id = C.FieldId.to_int field_id in
let field = List.nth variant.fields field_id in
let b =
Krml.Helpers.fresh_binder (mk_field_name field.C.field_name field_id) place_typ
in
K.with_type place_typ
K.(
EMatch
( Unchecked,
!*sub_e,
[
( [ b ],
with_type !*sub_e.typ
(PCons
( variant.C.variant_name,
List.init (List.length variant.fields) (fun i ->
if i = field_id then
with_type place_typ (PBound 0)
else
with_type TAny PWild) )),
with_type place_typ (EBound 0) );
] ))
end
| ( Field (ProjTuple n, i),
_,
C.TAdt { id = _; generics = { types = tys; const_generics = cgs; _ } } ) ->
let place_typ = typ_of_ty env p.ty in
assert (cgs = []);
(* match e with (_, ..., _, x, _, ..., _) -> x *)
let i = Charon.Types.FieldId.to_int i in
if List.length tys = 1 then begin
assert (i = 0);
(* Normalized one-element tuple *)
!*sub_e
end
else
let ts =
match !*sub_e.typ with
| TTuple ts -> ts
| _ -> assert false
in
assert (List.length ts = n);
let binders = [ Krml.Helpers.fresh_binder (uu ()) place_typ ] in
let pattern =
K.with_type !*sub_e.typ
(K.PTuple
(List.mapi
(fun i' t ->
K.with_type t
(if i = i' then
K.PBound 0
else
PWild))
ts))
in
let expr = K.with_type place_typ (K.EBound 0) in
K.with_type place_typ (K.EMatch (Unchecked, !*sub_e, [ binders, pattern, expr ]))
(* | PlaceProjection () *)
| _ -> fail "unexpected / ill-typed projection"
end
let expression_of_place (env : env) (p : C.place) : K.expr =
L.log "AstOfLlbc" "expression of place: %s" (C.show_place p);
expression_of_place env p
(* We produce bit-wise operators first, then when the type is of booleans, we
change into the non-B variants (Rust does not distinguish between bitwise and
boolean operators) *)
let op_of_unop (op : C.unop) : Krml.Constant.op =
match op with
| C.Not -> BNot
| C.Neg _ -> Neg
| _ -> failwith (C.show_unop op)
let op_of_binop (op : C.binop) : Krml.Constant.op =
match op with
| C.BitXor -> BXor
| C.BitAnd -> BAnd
| C.BitOr -> BOr
| C.Eq -> Eq
| C.Lt -> Lt
| C.Le -> Lte
| C.Ne -> Neq
| C.Ge -> Gte
| C.Gt -> Gt
| C.Div _ -> Div
| C.Rem _ -> Mod
| C.Add _ -> Add
| C.Sub _ -> Sub
| C.Mul _ -> Mult
| C.Shl _ -> BShiftL
| C.Shr _ -> BShiftR
| _ -> fail "unsupported operator: %s" (C.show_binop op)
let op_128_of_op kind (op : K.op) : K.expr =
let op_name =
match op with
| Add -> "add"
| Sub -> "sub"
| Mult -> "mul"
| Div -> "div"
| AddW -> "add"
| SubW -> "sub"
| MultW -> "mul"
| DivW -> "div"
| Mod -> "mod"
| BShiftL -> "shl"
| BShiftR -> "shr"
| BAnd -> "band"
| BOr -> "bor"
| BXor -> "bxor"
| Eq -> "eq"
| Neq -> "neq"
| Lt -> "lt"
| Lte -> "lte"
| Gt -> "gt"
| Gte -> "gte"
| Neg -> "neg"
| BNot -> "bnot"
| _ -> failwith "Unsupported operation for uint128"
in
Builtin.get_128_op (kind, op_name)
let mk_op_app (op : K.op) (first : K.expr) (rest : K.expr list) : K.expr =
(* For 128-bit integers, the case is different: convert the operator & match the case here *)
let op, ret_t =
if first.typ = Builtin.int128_t || first.typ = Builtin.uint128_t then
let op =
if first.typ = Builtin.int128_t then
op_128_of_op "i" op
else
op_128_of_op "u" op
in
let ret_t, _ = Krml.Helpers.flatten_arrow op.typ in
op, ret_t
else
(* Otherwise, simply the normal case *)
let op =
if first.typ = K.TBool then
match op with
| BNot -> Krml.Constant.Not
| BAnd -> And
| BOr -> Or
| BXor -> Xor
| op -> op
else
op
in
let op_t = Krml.Helpers.type_of_op op first.typ in
let op = K.(with_type op_t (EOp (op, first.typ))) in
let ret_t, _ = Krml.Helpers.flatten_arrow op_t in
op, ret_t
in
(* Rust is super lenient regarding the type of shift operators, we impose u32 -- see
https://doc.rust-lang.org/std/ops/trait.Shl.html
*)
(* Additionally, if the op is `shift` (BShiftL/R for usual, (u)int128_shl/r for 128 bits)
then the `rest` should be with a single element of type `uint32_t`
if it is not, turn to type casting. *)
(* Helper functions for this process *)
let is_128_bit_shift_lident lident =
[ Krml.Constant.BShiftL; BShiftR ]
|> List.concat_map (fun op -> [ op_128_of_op "i" op; op_128_of_op "u" op ])
|> List.map (fun (x : K.expr) -> Krml.Helpers.assert_elid x.K.node)
|> List.mem lident
in
let modify_rest : K.expr list -> K.expr list = function
| [ e2 ] -> begin
match e2.node with
| EConstant (_, s) ->
let i = int_of_string s in
assert (i >= 0);
[ Krml.Helpers.mk_uint32 i ]
| _ -> [ K.(with_type (TInt UInt32) (ECast (e2, TInt UInt32))) ]
end
| _ ->
failwith
"Invalid call to binary operator `shiftl` or `shiftr` -- the number of operands is not 2"
in
(* Modify here *)
let rest =
match op.node with
| EOp (BShiftL, _) | EOp (BShiftR, _) -> modify_rest rest
| EQualified lident when is_128_bit_shift_lident lident -> modify_rest rest
| _ -> rest
in
K.(with_type ret_t (EApp (op, first :: rest)))
let addrof ~const (e : K.expr) = K.(with_type (TBuf (e.typ, const)) (EAddrOf e))
(** Handling trait clauses as dictionaries *)
(* There are two ways that we skip synthesis of trait methods in function calls. The first one is if
a trait declaration is blocklisted. This happens if the trait has built-in support (e.g.
FnMut), or if the trait relies on unsupported features (e.g. provided methods,
used by Iterator's chunk_next, for instance; or associated types; or parent
clauses). The second way we skip trait methods (further down) is if the
function is a known builtin implementation. *)
let blocklisted_trait_decls =
[
(* These don't have methods *)
"core::marker::Sized";
"core::marker::MetaSized";
"core::marker::PointeeSized";
"core::marker::Send";
"core::marker::Sync";
"core::marker::Tuple";
"core::marker::Copy";
(* The traits below *should* be handled properly ASAP. But for now, we have specific *instances*
of those trait methods in the builtin lookup table, which we then implement by hand with
macros. *)
"core::iter::traits::iterator::Iterator";
"core::iter::range::Step";
(* TODO: figure out what to do with those *)
"core::clone::Clone";
(* TODO: these ones carry the drop_in_place code, but sometimes there's no
explicit impl (because it's trivial e.g. for usize) which is tricky. *)
"core::marker::Destruct";
"core::fmt::Debug";
"core::ptr::metadata::Thin";
]
(* Interpret a Rust function type, with trait bounds, into the krml Ast, providing:
- the type scheme (fields may be zero)
- the cg types, which only contains the original Rust const generic variables
- the argument types, prefixed by the dictionary-style passing of trait clause methods
- the return type
- whether the function is builtin, or not. *)
type lookup_result = {
ts : K.type_scheme; (* just for a sanity check *)
cg_types : K.typ list;
arg_types : K.typ list;
ret_type : K.typ;
is_known_builtin : bool;
}
let maybe_ts ts t =
if ts.K.n <> 0 || ts.n_cgs <> 0 then
K.TPoly (ts, t)
else
t
(* For a given function, a (flat) list of all the trait methods that are
transitively, possibly called by this function, based on the trait bounds in
its signature.
Using tests/where_clauses_simple as an example.
fn double (...)
this gets desugared to fn double where
T: Ops, <-- ClauseId 0 (required_methods: add, of_u32)
T: Copy, <-- ClauseId 1 (builtin, so neither required nor provided methods)
U: Ops, <-- ClauseId 2 (required_methods: add, of_u32)
U: Copy, <-- ClauseId 3 (builtin, so neither required nor provided methods)
the types we obtain by looking up the trait declaration have Self as 0
(DeBruijn).
When building a function declaration, this synthesizes all the extra binders
required for trait methods (passed as function pointers). Assumes type
variables have been suitably bound in the environment.
*)
let rec mk_clause_binders_and_args env ?depth ?clause_ref (trait_clauses : C.trait_param list) :
(var_id * K.typ) list =
let depth = Option.value ~default:"" depth in
List.concat_map
(fun tc ->
let {
C.clause_id;
trait = { binder_value = { id = trait_decl_id; generics = trait_generics }; _ };
_;
} =
tc
in
let trait_decl = env.get_nth_trait_decl trait_decl_id in
(* Every item inside the `trait_decl` may refer to generic params of the
trait. To get items that are valid to return outside of the scope of
the trait, we must substitute them with the given generics. We should
in principle substitute everything but we currently don't. This will
likely be a source of bugs. *)
let subst =
Charon.Substitute.make_subst_from_generics trait_decl.generics trait_generics Self
in
let substitute_visitor = Charon.Substitute.st_substitute_visitor in
let name = string_of_name env trait_decl.item_meta.name in
let clause_ref : C.trait_ref =
Option.value
~default:C.{ kind = C.Clause (Free clause_id); trait_decl_ref = tc.trait }
clause_ref
in
if List.mem name blocklisted_trait_decls then
[]
else begin
(* FYI, some clauses like Copy have neither required nor provided methods. *)
L.log "TraitClauses"
"%sclause decl %s\n\
\ id %d:\n\
\ decl_generics.types are %s\n\
\ decl_generics.const_generics are %s\n\
\ methods: %d\n"
depth name
(C.TraitClauseId.to_int clause_id)
(String.concat " ++ " (List.map C.show_ty trait_generics.C.types))
(String.concat " ++ " (List.map C.show_constant_expr trait_generics.C.const_generics))
(C.TraitMethodId.Map.cardinal trait_decl.C.methods);
(* 1. Associated constants *)
List.map
(fun (const : C.trait_assoc_const) ->
let trait_name = trait_decl.C.item_meta.name in
let pretty_name = string_of_name env trait_name ^ "_" ^ const.C.name in
let t = substitute_visitor#visit_ty subst const.C.ty in
let t = typ_of_ty env t in
( TraitClauseConstant
{ item_name = const.C.name; pretty_name; clause_id = clause_ref.kind },
t ))
trait_decl.C.consts
(* 2. Trait methods *)
@ List.map
(fun ((method_id, mthd) : _ * C.trait_method C.binder) ->
let item_name = mthd.C.binder_value.C.name in
let trait_name = trait_decl.C.item_meta.name in
let pretty_name = string_of_name env trait_name ^ "_" ^ item_name in
(* Ask charon for the properly bound method signature. *)
let bound_method_sig : C.fun_sig C.binder C.item_binder =
Option.get (Charon.Substitute.lookup_method_sig env.crate trait_decl_id method_id)
in
(* First we substitute the trait generics. *)
let bound_method_sig : C.fun_sig C.binder =
Charon.Substitute.apply_args_to_item_binder clause_ref.kind trait_generics
(substitute_visitor#visit_binder substitute_visitor#visit_fun_sig)
bound_method_sig
in
(* We then construct a polymorphic signature for this method.
Its generics are the method generics (the ones in the binder).
*)
let method_sig =
Charon.Substitute.(
(* Variables bound in the inner binder are `Bound`, which
eurydice doesn't handle. We therefore make them all `Free`
variables, shifting indices to avoid overlap with existing
in-scope variables. *)
let ambient_ts =
{ K.n = List.length env.type_binders; K.n_cgs = List.length env.cg_binders }
in
let shift_ty_var varid =
C.TypeVarId.of_int (C.TypeVarId.to_int varid + ambient_ts.K.n)
in
let shift_cg_var varid =
C.ConstGenericVarId.of_int
(C.ConstGenericVarId.to_int varid + ambient_ts.K.n_cgs)
in
(* Replace bound variables with free variables that don't
overlap with existing ones. *)
let subst =
subst_remove_binder_zero
{
empty_free_sb_subst with
ty_sb_subst =
(fun varid -> empty_free_sb_subst.ty_sb_subst (shift_ty_var varid));
cg_sb_subst =
(fun varid -> empty_free_sb_subst.cg_sb_subst (shift_cg_var varid));
}
in
let signature =
st_substitute_visitor#visit_fun_sig subst bound_method_sig.binder_value
in
(* Gotta shift the params too, as trait clause may refer to bound types. *)
let method_params =
st_substitute_visitor#visit_generic_params subst bound_method_sig.binder_params
in
(* Finally, update the parameters so they use the new, shifted indices. *)
let method_params =
{
method_params with
types =
List.map
(fun (var : C.type_param) ->
{ var with C.index = shift_ty_var var.C.index })
method_params.types;
const_generics =
List.map
(fun (var : C.const_generic_param) ->
{ var with C.index = shift_cg_var var.C.index })
method_params.const_generics;
}
in
{ C.item_binder_params = method_params; item_binder_value = signature })
in
L.log "TraitClauses" "%s computed method signature %s::%s:\n%s" depth name item_name
(Charon.Print.fun_sig_to_string env.format_env "" " " method_sig);
let ts, t = typ_of_signature env method_sig in
let t = maybe_ts ts t in
( TraitClauseMethod
{ method_id; item_name; pretty_name; clause_id = clause_ref.kind; ts },
t ))
(C.TraitMethodId.Map.to_list trait_decl.C.methods)
(* 1 + 2, recursively, for parent traits *)
@ List.concat_map
(fun (parent_clause : C.trait_param) ->
(* Make the clause valid outside the scope of the trait decl. *)
let parent_clause = substitute_visitor#visit_trait_param subst parent_clause in
(* Mapping of the methods of the parent clause *)
let clause_ref : C.trait_ref =
{
kind = ParentClause (clause_ref, parent_clause.clause_id);
trait_decl_ref = parent_clause.trait;
}
in
mk_clause_binders_and_args env ~depth:(depth ^ "--") ~clause_ref [ parent_clause ])
trait_decl.C.implied_clauses
end)
trait_clauses
and lookup_signature env depth (signature : C.bound_fun_sig) : lookup_result =
let {
C.item_binder_params = { types = type_params; const_generics; trait_clauses; _ };
item_binder_value = { C.inputs; output; _ };
} =
signature
in
L.log "Calls" "%s# Lookup Signature\n%s--> args: %s, ret: %s\n" depth depth
(String.concat " ++ " (List.map (Charon.Print.ty_to_string env.format_env) inputs))
(Charon.Print.ty_to_string env.format_env output);
L.log "Calls" "%sType parameters for this signature: %s\n" depth
(String.concat " ++ " (List.map Charon.Print.type_param_to_string type_params));
let env = push_cg_binders env const_generics in
let env = push_type_binders env type_params in
let clause_binders = mk_clause_binders_and_args env trait_clauses in
debug_trait_clause_mapping env clause_binders;
let clause_ts = List.map snd clause_binders in
{
ts = { n = List.length type_params; n_cgs = List.length const_generics };
cg_types = List.map (fun (v : C.const_generic_param) -> typ_of_ty env v.ty) const_generics;
arg_types =
(clause_ts
@ List.map (typ_of_ty env) inputs
@
if inputs = [] then
[ K.TUnit ]
else
[]);
ret_type = typ_of_ty env output;
is_known_builtin = false;
}
(* Transforms a lookup result into a usable type, taking into account the fact that the internal Ast
is ML-style and does not have zero-argument functions. *)
and typ_of_signature env signature =
let { cg_types = const_generics_ts; arg_types = inputs; ret_type = output; ts; _ } =
lookup_signature env "" signature
in
let adjusted_inputs = const_generics_ts @ inputs in
let t = Krml.Helpers.fold_arrow adjusted_inputs output in
ts, t
and debug_trait_clause_mapping env (mapping : (var_id * K.typ) list) =
if mapping = [] then
L.log "TraitClauses" "# Debug Mapping\nIn this function, trait clause mapping is empty"
else
L.log "TraitClauses"
"# Debug Mapping\nIn this function, calls to trait bound methods are as follows:";
List.iter
(fun (clause_entry, t) ->
match clause_entry with
| TraitClauseMethod { clause_id; item_name; ts; _ } ->
L.log "TraitClauses" "@@@ method name: %s" item_name;
L.log "TraitClauses" "%s::%s: %a has trait-level %d const generics, %d type vars\n"
(Charon.Print.trait_ref_kind_to_string env.format_env None clause_id)
item_name ptyp t ts.K.n_cgs ts.n
| TraitClauseConstant { clause_id; item_name; _ } ->
L.log "TraitClauses" "@@@ method name: %s" item_name;
L.log "TraitClauses" "%s::%s: associated constant %a\n"
(Charon.Print.trait_ref_kind_to_string env.format_env None clause_id)
item_name ptyp t
| _ -> ())
mapping
(** Compiling function instantiations into krml application nodes. *)
(* First step: produce an expression for the un-instantiated function reference, along with all the
type information required to build a proper instantiation. The function reference is an expression
that is either a reference to a variable in scope (trait methods), or to a top-level qualified
name, which encompasses both externally-defined function (builtins), or regular functions. *)
let lookup_fun (env : env) depth (fn_ptr : C.fn_ptr) : K.expr' * lookup_result =
let open RustNames in
let matches p = Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config p fn_ptr in
let builtin b =
let { Builtin.name; typ; n_type_args; cg_args; _ } = b in
let ret_type, arg_types = Krml.Helpers.flatten_arrow typ in
let ts = { K.n = n_type_args; K.n_cgs = List.length cg_args } in
K.EQualified name, { ts; arg_types; ret_type; cg_types = cg_args; is_known_builtin = true }
in
match List.find_opt (fun (p, _) -> matches p) (known_builtins !Options.no_const) with
| Some (_, b) -> builtin b
| None -> (
let lookup_result_of_fun_id fun_id =
let decl = env.get_nth_function fun_id in
let lid = lid_of_name env decl.C.item_meta.name in
L.log "Calls" "%s--> name: %a" depth plid lid;
K.EQualified lid, lookup_signature env depth (C.bound_fun_sig_of_decl decl)
in
match fn_ptr.kind with
| FunId (FRegular f) -> lookup_result_of_fun_id f
| FunId (FBuiltin f) -> fail "unknown builtin function: %s" (C.show_builtin_fun_id f)
| TraitMethod (trait_ref, method_id, _trait_opaque_signature) -> (
match trait_ref.kind with
| TraitImpl { id; _ } ->
let trait_impl = env.get_nth_trait_impl id in
let f =
try C.TraitMethodId.Map.find method_id trait_impl.methods
with Not_found ->
fail "Error looking trait impl: %s%!"
(Charon.Print.fn_ptr_to_string env.format_env fn_ptr)
in
lookup_result_of_fun_id f.C.binder_value.id
| (Clause _ | ParentClause _) as tcid ->
let f, t, sig_info = lookup_clause_method env tcid method_id in
(* the sig_info is kind of redundant here *)
let t =
match t with
| TPoly (_, t) -> t
| _ -> t
in
let ret_type, arg_types = Krml.Helpers.flatten_arrow t in
let cg_types, arg_types = Krml.KList.split sig_info.n_cgs arg_types in
EBound f, { ts = sig_info; cg_types; arg_types; ret_type; is_known_builtin = false }
| _ ->
fail "Error looking trait ref: %s%!"
(Charon.Print.fn_ptr_to_string env.format_env fn_ptr)))
let fn_ptr_is_opaque env (fn_ptr : C.fn_ptr) =
match fn_ptr.kind with
| FunId (FRegular id) -> (
try
match (env.get_nth_function id).body with
| StructuredBody _ -> false
| _ -> true
with Not_found -> false)
| _ -> false
(* This is a very core piece of logic that transforms a Rust fn_ptr into a krml AST node that
contains type application, const generic applications, and application of trait methods to
implement the dictionary-passing style. *)
let rec expression_of_fn_ptr env depth (fn_ptr : C.fn_ptr) =
let {
C.generics = { types = type_args; const_generics = const_generic_args; trait_refs; _ };
kind;
_;
} : C.fn_ptr =
fn_ptr
in
(* We handle any kind of fn_ptr, whether it's a concrete function call, a
concrete trait implementation method call, or an abstract trait method call
(e.g. a call to T::f when T is a trait bound in scope). *)
L.log "Calls" "%sVisiting call: %s" depth (Charon.Print.fn_ptr_to_string env.format_env fn_ptr);
L.log "Calls" "%s--> %d type_args, %d const_generics, %d trait_refs" depth (List.length type_args)
(List.length const_generic_args) (List.length trait_refs);
(* In case this is a call to a trait implementation method, there are two
levels of applications: the trait-generic arguments (i.e. impl for ...)
and the method-generic arguments (i.e. fn f). The method appears as
a top-level function that receives all the arguments for T and U (types,
const generics, trait references), and when we synthesize a call node, we
do behave accordingly and provide arguments for both T and U. *)
let type_args, const_generic_args, trait_refs =
let generics =
match kind with
| TraitMethod ({ kind = TraitImpl { generics; _ }; _ }, _, _) ->
L.log "Calls" "%s--> this is a trait method" depth;
generics
| _ -> C.empty_generic_args
in
( generics.types @ type_args,
generics.const_generics @ const_generic_args,
generics.trait_refs @ trait_refs )
in
L.log "Calls" "%s--> %d type_args, %d const_generics, %d trait_refs" depth (List.length type_args)
(List.length const_generic_args) (List.length trait_refs);
L.log "Calls" "%s--> trait_refs: %s\n" depth
(String.concat " ++ " (List.map (Charon.Print.trait_ref_to_string env.format_env) trait_refs));
L.log "Calls" "%s--> pattern: %s" depth (string_of_fn_ptr env fn_ptr);
L.log "Calls" "%s--> type_args: %s" depth
(String.concat ", " (List.map (Charon.Print.ty_to_string env.format_env) type_args));
(* The function itself, along with information about its *signature*. *)
let f, { ts; arg_types = inputs; ret_type = output; cg_types = cg_inputs; is_known_builtin } =
lookup_fun env depth fn_ptr
in
L.log "Calls" "%s--> %d inputs: %a" depth (List.length inputs) ptyps inputs;
L.log "Calls" "%s--> is_known_builtin?: %b" depth is_known_builtin;
(* Translate effective type and cg arguments. *)
let const_generic_args =
match f, type_args with
| EQualified lid, [ _; TRef (_, TArray (_, cg), _); _ ]
when lid = Builtin.slice_to_ref_array.name ->
(* Special case, we *do* need to retain the length, which would disappear if we simply did
typ_of_ty (owing to array decay rules). *)
[ expression_of_const_generic env cg ]
| _ -> List.map (expression_of_const_generic env) const_generic_args
in
let type_args = List.map (typ_of_ty env) type_args in
(* Handling trait implementations for generic trait bounds in the callee. We
synthesize krml expressions that correspond to each one of the trait methods
that the callee expects. Order matters here. *)
let fn_ptrs : K.expr list =
if is_known_builtin then
(* If this is a known builtin implementation, we do not materialize trait methods, on the
basis that this is likely something from the standard library that exercises more features
that we can support, and that since we hand-write it, we don't need this level of precision
anyhow. *)
[]
else
(* MUST have the same structure as mk_clause_binders_and_args *)
let rec build_trait_ref_mapping depth (trait_refs : C.trait_ref list) =
List.concat_map
(fun (trait_ref : C.trait_ref) ->
let name =
string_of_name env
(env.get_nth_trait_decl trait_ref.trait_decl_ref.binder_value.id).item_meta.name
in
L.log "Calls" "%s--> trait_ref %s: %s\n" depth name (C.show_trait_ref trait_ref);
match trait_ref.kind with
| _ when List.mem name blocklisted_trait_decls ->
(* Trait not supported -- don't synthesize arguments *)
[]
| TraitImpl { id = impl_id; generics = _generics } ->
(* Call-site has resolved trait clauses into a concrete trait implementation. *)
let trait_impl : C.trait_impl = env.get_nth_trait_impl impl_id in
(* This must be in agreement, and in the same order as mk_clause_binders_and_args *)
List.map
(fun ((_item_name, { C.id; generics }) : _ * C.global_decl_ref) ->
if
not
(generics.types = [] && generics.const_generics = []
&& generics.trait_refs = [])
then
failwith "TODO: polymorphic globals";
let global = env.get_nth_global id in
K.with_type (typ_of_ty env global.ty)
(K.EQualified (lid_of_name env global.item_meta.name)))
trait_impl.consts
@ List.map
(fun ((method_id, bound_fn) : _ * C.fun_decl_ref C.binder) ->
let fun_decl_id = bound_fn.C.binder_value.C.id in
let fn_ptr : C.fn_ptr =
{
kind = TraitMethod (trait_ref, method_id, fun_decl_id);
generics = Charon.TypesUtils.empty_generic_args;
}
in
let fn_ptr = fst3 (expression_of_fn_ptr env (depth ^ " ") fn_ptr) in
fn_ptr)
(C.TraitMethodId.Map.to_list trait_impl.methods)
@ build_trait_ref_mapping (" " ^ depth)
(let subst =
Charon.Substitute.make_subst_from_generics trait_impl.generics _generics Self
in
(*_generics.trait_refs*)
List.map
(Charon.Substitute.st_substitute_visitor#visit_trait_ref subst)
trait_impl.implied_trait_refs)
| Clause _ as clause_id ->
(* Caller it itself polymorphic and refers to one of its own clauses to synthesize
the clause arguments at call-site. We must pass whatever is relevant for this
clause, *transitively* (this means all the reachable parents). *)
let rec relevant = function
| C.ParentClause (tref', _) -> relevant tref'.kind
| clause_id' -> clause_id = clause_id'
in
List.rev
(Krml.KList.filter_mapi
(fun i (var, t) ->
match var with
| TraitClauseMethod { clause_id = clause_id'; _ }
| TraitClauseConstant { clause_id = clause_id'; _ }
when relevant clause_id' -> Some K.(with_type t (EBound i))
| _ -> None)
env.binders)
| ParentClause (tref, clause_id) ->
let decl_id = tref.trait_decl_ref.binder_value.id in
let trait_decl = env.get_nth_trait_decl decl_id in
let name = string_of_name env trait_decl.item_meta.name in
let clause_id = C.TraitClauseId.to_int clause_id in
let parent_clause = List.nth trait_decl.implied_clauses clause_id in
let parent_clause_decl =
env.get_nth_trait_decl parent_clause.trait.binder_value.id
in
let parent_name = string_of_name env parent_clause_decl.item_meta.name in
Krml.KPrint.bprintf "looking up parent clause #%d of decl=%s = %s\n" clause_id name
parent_name;
if List.mem parent_name blocklisted_trait_decls then
[]
else
failwith
("Don't know how to resolve trait_ref above (2): "
^ Charon.Print.trait_ref_to_string env.format_env trait_ref)
| _ ->
failwith
("Don't know how to resolve trait_ref above (2): "
^ Charon.Print.trait_ref_to_string env.format_env trait_ref))
trait_refs
in
build_trait_ref_mapping depth trait_refs
in
L.log "Calls" "%s--> trait method impls: %d" depth (List.length fn_ptrs);
(* This needs to match what is done in the FunGroup case (i.e. when we extract
a definition). There are two behaviors depending on whether the function is
builtin or not. *)
let inputs =
if inputs = [] then
[ K.TUnit ]
else
inputs
in
(* From here on, this is only krml logic, which is about building
properly-annotated internal nodes that take care of instantiating generic
type schemes, dealing with type applications, const genericss, etc.
followed by the application of trait methods (in the special TApp node). *)
let t_unapplied = maybe_ts ts (Krml.Helpers.fold_arrow (cg_inputs @ inputs) output) in
let offset = List.length env.binders - List.length env.cg_binders in
L.log "Calls" "%s--> t_unapplied: %a" depth ptyp t_unapplied;
L.log "Calls" "%s--> inputs: %a" depth ptyps inputs;
L.log "Calls" "%s--> const_generic_args: %a (offset: %d)" depth pexprs const_generic_args offset;
L.log "Calls" "%s--> %d fn_ptrs: %a (offset: %d)" depth (List.length fn_ptrs)
(fun k e ->
List.iter
(fun e ->
pexpr k e;
Buffer.add_string k ": ";
ptyp k e.typ)
e)
fn_ptrs offset;
let t_applied =
match t_unapplied with
| TPoly ({ n; n_cgs }, t) ->
let ts =
{ K.n = n - List.length type_args; n_cgs = n_cgs - List.length const_generic_args }
in
if ts.n > 0 || ts.n_cgs > 0 then
K.TPoly (ts, t)
else
t
| t -> t
in
L.log "Calls" "%s--> t_applied (1): %a" depth ptyp t_applied;
let t_applied =
Krml.DeBruijn.(subst_tn type_args (subst_ctn offset const_generic_args t_applied))
in
L.log "Calls" "%s--> t_applied (2): %a" depth ptyp t_applied;
let t_applied =
match t_applied with
| TPoly (ts, t) ->
assert (fn_ptrs = []);
let ret, args = Krml.Helpers.flatten_arrow t in
let _, args = Krml.KList.split (List.length const_generic_args) args in
K.TPoly (ts, Krml.Helpers.fold_arrow args ret)
| t ->
let ret, args = Krml.Helpers.flatten_arrow t in
if List.length const_generic_args + List.length fn_ptrs > List.length args then
L.log "Calls" "ERROR in %s" (Charon.Print.fn_ptr_to_string env.format_env fn_ptr);
let _, args =
Krml.KList.split (List.length const_generic_args + List.length fn_ptrs) args
in
Krml.Helpers.fold_arrow args ret
in
L.log "Calls" "%s--> t_applied: %a" depth ptyp t_applied;
let hd =
let hd = K.with_type t_unapplied f in
if type_args <> [] || const_generic_args <> [] || fn_ptrs <> [] then
K.with_type t_applied (K.ETApp (hd, const_generic_args, fn_ptrs, type_args))
else
hd
in
L.log "Calls" "%s--> hd: %a" depth pexpr hd;
( hd,
is_known_builtin,
match t_applied with
| TPoly (ts, t) -> K.TPoly (ts, fst (Krml.Helpers.flatten_arrow t))
| t -> fst (Krml.Helpers.flatten_arrow t) )
let expression_of_fn_ptr env (fn_ptr : C.fn_ptr) = expression_of_fn_ptr env "" fn_ptr
let global_is_const env id =
match (env.get_nth_global id).global_kind with
| NamedConst | AnonConst -> true
| Static -> false
let expression_of_operand (env : env) (op : C.operand) : K.expr =
match op with
| Copy ({ kind = PlaceGlobal { id; _ }; _ } as p) when global_is_const env id ->
(* No need to copy a const since by definition it cannot be modified *)
expression_of_place env p
| Copy p -> expression_of_place env p
| Move p -> expression_of_place env p
| Constant { kind = CLiteral l; _ } -> expression_of_literal env l
| Constant { kind = CVar var; _ } -> expression_of_cg_var_id env (C.expect_free_var var)
| Constant { kind = CFnDef fn_ptr; _ } ->
let e, _, _ = expression_of_fn_ptr env fn_ptr in
e
| Constant { kind = CTraitConst (({ C.kind; _ } as trait_ref), name); _ } -> begin
(* Logic similar to lookup_fun *)
match kind with
| Clause _ | ParentClause _ ->
let i, t = lookup_clause_constant env kind name in
K.(with_type t (EBound i))
| TraitImpl { id; _ } ->
let trait = env.get_nth_trait_impl id in
let global =
try List.assoc name trait.consts
with Not_found ->
fail "Error looking trait impl: %s %s%!"
(Charon.Print.trait_ref_to_string env.format_env trait_ref)
name
in
let global = env.get_nth_global global.C.id in
K.with_type (typ_of_ty env global.ty)
(K.EQualified (lid_of_name env global.item_meta.name))
| _ ->
fail "expression_of_operand Constant: %s"
(Charon.Print.operand_to_string env.format_env op)
end
| Constant { kind = CAdt _; ty } when Charon.TypesUtils.ty_is_unit ty -> K.with_type TUnit K.EUnit
| Constant _ ->
fail "expression_of_operand: %s" (Charon.Print.operand_to_string env.format_env op)
let is_str env var_id =
match lookup_with_original_type env var_id with
| _, _, TRef (_, TAdt { id = TBuiltin TStr; generics = { types = []; _ } }, _) -> true
| _ -> false
let is_box_place (p : C.place) =
match p.ty with
| C.TAdt { id = TBuiltin TBox; _ } -> true
| _ -> false
(* returns either a regular naked C pointer, or a fat pointer in the case of DSTs (i.e. with non-empty metadata) *)
let mk_reference ~const (e : K.expr) (metadata : K.expr) : K.expr =
match metadata.typ with
(* When it is unit, it means there is no metadata, simply take the address *)
| K.TUnit -> addrof ~const e
| _ -> (
match e.typ with
| TApp (lid, [ t ]) when lid = Builtin.derefed_slice ->
(* The special "base case" of DSTs: slice
where we have to cast [derefed_slice] into [T*] for the .ptr field in the fat pointer *)
let ptr = K.(with_type (TBuf (t, const)) (ECast (e, TBuf (t, const)))) in
K.(
with_type
(Builtin.mk_dst_ref ~const t metadata.typ)
(EFlat [ Some "ptr", ptr; Some "meta", metadata ]))
| _ ->
K.(
with_type
(Builtin.mk_dst_ref ~const e.typ metadata.typ)
(EFlat [ Some "ptr", addrof ~const e; Some "meta", metadata ])))
(* To destruct a DST reference type into its base and metadata types
I.e., from Eurydice_dst_ref to (T, meta) *)
let destruct_dst_ref_typ t =
match t with
| K.TApp (dst_ref_hd, [ t_base; t_meta ]) when is_dst_ref dst_ref_hd -> Some (t_base, t_meta)
| _ -> None
(* Get the base pointer expression from a DST reference expression
I.e., from `e : Eurydice_dst_ref` to `e.ptr : T*` *)
let get_dst_ref_base dst_ref =
match destruct_dst_ref_typ dst_ref.K.typ with
(* XXX fixme *)
| Some (base, _) -> Some K.(with_type (TBuf (base, false)) (EField (dst_ref, "ptr")))
| None -> None
(* Parse the fat pointer Eurydice_dst_ref, _> into (T,T),
where the ignored field `_` must be `usize` as metadata,
used to handle the unsized cast from &T to &T *)
let destruct_arr_dst_ref t =
match t with
| K.TApp (dst_ref_hd, [ (TApp (lid, _) as t_u); _ ]) when is_dst_ref dst_ref_hd -> Some (lid, t_u)
| _ -> None
(* Reborrows allow going from a mutable slice to an immutable one. *)
let maybe_reborrow_slice t_dst e_src =
let open K in
match e_src.typ, t_dst with
| TApp (hd1, [ t_ptr; t_meta ]), TApp (hd2, _) when is_dst_ref hd1 && is_dst_ref hd2 && hd1 <> hd2
->
let mk e =
with_type t_dst
(EFlat
[
Some "ptr", with_type (TBuf (t_ptr, true)) (EField (e, "ptr"));
Some "meta", with_type t_meta (EField (e, "meta"));
])
in
if Krml.Helpers.is_readonly_c_expression e_src then
mk e_src
else
with_type t_dst
(ELet
( Krml.Helpers.fresh_binder "reborrowed_slice" e_src.typ,
e_src,
mk (with_type e_src.typ (EBound 0)) ))
| _ -> e_src
let expression_of_rvalue (env : env) (p : C.rvalue) expected_ty : K.expr =
match p with
| Use op -> expression_of_operand env op
(* Generally, MIR / current LLBC is guaranteed to apply [Deref] only to places that are
references or raw pointers, in these cases [&*p] == [p].
The [Deref] traits types are desugared to function calls to [deref].
The ONLY exception is when the place is a [Box]. That is, MIR/LLBC might generate [*b]
where [b] is a [Box]. This refers to taking the value out of the [Box].
Recall that [Box] is a wrapper of [Unique], which is in turn a wrapper of a [NonNull],
which is a wrapper of a raw pointer. Hence, [*b] when [b] is a [Box] is equivalent to
[*(b.0.pointer.pointer)]. This is a compiler magic.
However, in Eurydice *now*, [Box] types are instantly unboxed to raw pointers, which
coincides exactly with our current implementation, hence no extra handling is needed.
In the future however, we might want to handle [Box] types differently, so this is a note
to ourselves to be careful with this.
*)
| RvRef ({ kind = PlaceProjection (p, Deref); _ }, _, _)
| RawPtr ({ kind = PlaceProjection (p, Deref); _ }, _, _) ->
(* Notably, this is NOT simply an optimisation, as this represents re-borrowing, and [p] might
be a reference to DST (fat pointer). *)
(* This also works for when the case has metadata, simply ignore it *)
maybe_reborrow_slice (typ_of_ty env expected_ty) (expression_of_place env p)
| RvRef (p, bk, metadata) ->
let metadata = expression_of_operand env metadata in
let e = expression_of_place env p in
mk_reference ~const:(const_of_borrow_kind bk) e metadata
| RawPtr (p, rk, metadata) ->
let metadata = expression_of_operand env metadata in
let e = expression_of_place env p in
mk_reference ~const:(const_of_ref_kind rk) e metadata
| NullaryOp (SizeOf, ty) ->
let t = typ_of_ty env ty in
K.(with_type TBool (EApp (Builtin.(expr_of_builtin_t sizeof [ t ]), [])))
| NullaryOp (AlignOf, ty) ->
let t = typ_of_ty env ty in
K.(with_type TBool (EApp (Builtin.(expr_of_builtin_t alignof [ t ]), [])))
| UnaryOp (Cast (CastScalar (_, dst)), e) ->
let dst = typ_of_literal_ty env dst in
K.with_type dst (K.ECast (expression_of_operand env e, dst))
| UnaryOp (Cast (CastRawPtr (_from, to_)), e) ->
let dst = typ_of_ty env to_ in
K.with_type dst (K.ECast (expression_of_operand env e, dst))
| UnaryOp (Cast (CastTransmute ((TRawPtr _ as _from), (TLiteral (TUInt Usize) as to_))), e) ->
let dst = typ_of_ty env to_ in
K.with_type dst (K.ECast (expression_of_operand env e, dst))
| UnaryOp (Cast (CastFnPtr (TFnDef _from, TFnPtr _to)), e) ->
(* From FnDef to FnPtr *)
if Charon.Substitute.lookup_fndef_sig env.crate _from = Some _to then
expression_of_operand env e
else
let dst = typ_of_ty env (TFnPtr _to) in
K.with_type dst (K.ECast (expression_of_operand env e, dst))
| UnaryOp (Cast (CastFnPtr (TFnPtr _, TFnPtr _)), e) ->
(* possible safe fn to unsafe fn, same in C *)
expression_of_operand env e
| UnaryOp (Cast (CastUnsize (ty_from, ty_to, meta) as ck), e) ->
(* DSTs: we support going from &T to &T where S1 is sized, S2 is
unsized and &T becomes a fat pointer. The base case is from &T<[U;N]>
to T<[U]>. See test/more_dst.rs for user-defined DST case. We build this
coercion by hand, and slightly violate C's strict aliasing rules. *)
let t_from = typ_of_ty env ty_from and t_to = typ_of_ty env ty_to in
let e = expression_of_operand env e in
begin
match meta, t_from, destruct_arr_dst_ref t_to with
| MetaLength cg, TBuf (TApp (lid1, _), const), Some (lid2, t_u) when lid1 = lid2 ->
(* Cast from a struct whose last field is `t data[n]` to a struct whose last field is
`Eurydice_derefed_slice data` (a.k.a. `char data[]`) *)
let len = expression_of_const_generic env cg in
let ptr = K.with_type (TBuf (t_u, const)) (K.ECast (e, TBuf (t_u, const))) in
Builtin.dst_new ~const ~len ~ptr t_u
| MetaLength cg, TBuf (K.TCgApp (K.TApp (lid_arr, [ t ]), _), _), _
when lid_arr = Builtin.arr ->
(* Cast from Box<[T;N]> (represented as a mut reference to an array) to Box<[T]> (which we
represent as a slice). See the translation of types. *)
let len = expression_of_const_generic env cg in
let const =
match t_to with
| K.TApp (dst_ref_hd, _) when dst_ref_hd = Builtin.dst_ref_shared -> true
| K.TApp (dst_ref_hd, _) when dst_ref_hd = Builtin.dst_ref_mut -> false
| _ -> assert false
in
let array_to_slice =
RustNames.builtin_of_function
(if const then
Builtin.array_to_slice_func_shared
else
Builtin.array_to_slice_func_mut)
in
let t_without_cg = array_to_slice.typ in
(* array_to_slice: size_t -> arr -> Eurydice_slice 0 *)
let array_to_slice = Builtin.(expr_of_builtin array_to_slice) in
let diff = List.length env.binders - List.length env.cg_binders in
let array_to_slice =
K.with_type
Krml.DeBruijn.(subst_t t 0 (subst_ct diff len 0 t_without_cg))
(K.ETApp (array_to_slice, [ len ], [], [ t ]))
in
K.(with_type (Builtin.mk_slice ~const t) (EApp (array_to_slice, [ e ])))
| _, _, _ ->
Krml.KPrint.bprintf "t_to = %a\n" ptyp t_to;
Krml.KPrint.bprintf "destruct_arr_dst_ref t_to = None? %b\n"
(destruct_arr_dst_ref t_to = None);
Krml.Warn.fatal_error "unknown unsize cast: `%s`\nt_to=%a\nt_from=%a"
(Charon.Print.cast_kind_to_string env.format_env ck)
ptyp t_to ptyp t_from
end
| UnaryOp (Cast (CastConcretize (_from_ty, to_ty)), e) -> (
(* Concretization cast is a no-op at runtime *)
let op_e = expression_of_operand env e in
let typ = typ_of_ty env to_ty in
match get_dst_ref_base op_e with
| Some base_ptr -> K.(with_type typ (ECast (base_ptr, typ)))
| None ->
failwith
("unknown concretize cast: `"
^ Charon.Print.cast_kind_to_string env.format_env (CastConcretize (_from_ty, to_ty))
^ "`"))
| UnaryOp (Cast ck, e) ->
(* Add a simpler case: identity cast is allowed *)
let is_ident =
match ck with
(* Here are `literal_type`s *)
| C.CastScalar (f, t) -> f = t
(* The following are `type`s *)
| C.CastFnPtr (f, t) | C.CastRawPtr (f, t) | C.CastUnsize (f, t, _) | C.CastTransmute (f, t)
-> f = t
| C.CastConcretize _ -> false
in
if is_ident then
expression_of_operand env e
else
failwith ("unknown cast: `" ^ Charon.Print.cast_kind_to_string env.format_env ck ^ "`")
(* | UnaryOp (PtrMetadata, e) ->
let e = expression_of_operand env e in begin
match e.typ with
| TApp (lid, [ _; meta_ty ]) when lid = Builtin.dst_ref ->
K.(with_type meta_ty (EField (e, "meta")))
(* In cases like `PtrMetadata(T)` when `T` is a type variable or some types with unresolved type variable,
We cannot tell the correct metadata type from it until fully monomorphized.
But we can surely rely on monomorphized LLBC, and we ignore handling such cases in Eurydice. *)
| ty when has_unresolved_generic ty ->
failwith "Eurydice do not handle ptr-metadata for generic types. Consider using monomorphized LLBC."
(* Otherwise, fetching ptr-metadata from a non-DST simply results in `()`
When a type is fully resolved and it is not `Eurydice::DstRef`, we can be confident that it is not a DST. *)
| _ -> K.with_type TUnit K.EUnit
end *)
| UnaryOp (op, o1) -> mk_op_app (op_of_unop op) (expression_of_operand env o1) []
| BinaryOp (op, o1, o2) ->
mk_op_app (op_of_binop op) (expression_of_operand env o1) [ expression_of_operand env o2 ]
| Discriminant sub_p ->
let e = expression_of_place env sub_p in
let expected_t = typ_of_ty env expected_ty in
K.(
with_type expected_t
(EApp (Builtin.(expr_of_builtin_t discriminant) [ e.typ; expected_t ], [ e ])))
| Aggregate (AggregatedAdt ({ id = TTuple; _ }, _, None), ops) -> begin
match ops with
| [] -> K.with_type TUnit K.EUnit
| [ op ] -> expression_of_operand env op
| _ ->
let ops = List.map (expression_of_operand env) ops in
let ts = List.map (fun x -> x.K.typ) ops in
K.with_type (TTuple ts) (K.ETuple ops)
end
| Aggregate
( AggregatedAdt
( { id = TAdtId typ_id; generics = { types = typ_args; const_generics; _ } },
variant_id,
None ),
args ) ->
let { C.item_meta; kind; _ } = env.get_nth_type typ_id in
let name = item_meta.name in
let typ_lid = lid_of_name env name in
let typ_args = List.map (typ_of_ty env) typ_args in
let cg_args = List.map (cg_of_const_generic env) const_generics in
let t = K.fold_tapp (typ_lid, typ_args, cg_args) in
let args = List.map (expression_of_operand env) args in
begin
match variant_id with
| Some variant_id ->
let variant_id = (find_nth_variant env typ_id variant_id).variant_name in
if is_enum env typ_id then
K.with_type t (K.EEnum (mk_enum_case typ_lid variant_id))
else
K.with_type t (K.ECons (variant_id, args))
| None ->
let fields =
match kind with
| Struct fields -> fields
| Enum _ -> failwith "TODO: Enum"
| Union _ -> failwith "TODO: Union"
| Opaque -> failwith "TODO: Opaque"
| Alias _ -> failwith "TODO: Alias"
| TDeclError _ -> failwith "TODO: TDeclError"
in
K.with_type t
(K.EFlat
(List.mapi
(fun i (f, a) -> Some (ensure_named i f.C.field_name), a)
(List.combine fields args)))
end
| Aggregate (AggregatedAdt ({ id = TBuiltin _; _ }, _, _), _) ->
failwith "unsupported: AggregatedAdt / TAssume"
| Aggregate (AggregatedArray (t, cg), ops) ->
let ty = typ_of_ty env t in
let typ_arr = typ_of_struct_arr env t cg in
begin
match ops with
| [] ->
let empty_array =
K.with_type
Krml.DeBruijn.(subst_t ty 0 Builtin.empty_array.typ)
(K.ETApp (Builtin.(expr_of_builtin empty_array), [], [], [ ty ]))
in
K.with_type typ_arr (K.EApp (empty_array, [ K.with_type ty K.EAny ]))
(* a dummy arg is needed to pass the checker *)
| _ ->
let array_expr =
K.with_type
(TArray (typ_of_ty env t, constant_of_scalar_value (assert_cg_scalar cg)))
(K.EBufCreateL (Stack, List.map (expression_of_operand env) ops))
in
K.with_type typ_arr (mk_expr_arr_struct array_expr)
end
| rvalue ->
failwith ("unsupported rvalue: `" ^ Charon.Print.rvalue_to_string env.format_env rvalue ^ "`")
let expression_of_assertion (env : env) ({ cond; expected; _ } : C.assertion) : K.expr =
let cond =
if not expected then
expression_of_operand env cond
else
Krml.Helpers.mk_not (expression_of_operand env cond)
in
K.(
with_type TAny
(EIfThenElse (cond, with_type TAny (EAbort (None, Some "assert failure")), Krml.Helpers.eunit)))
let lesser t1 t2 =
if t1 = K.TAny then
t2
else if t2 = K.TAny then
t2
else if t1 <> t2 then
fail "lesser t1=%a t2=%a" ptyp t1 ptyp t2
else
t1
(* A `fn` pointer, which does not have trait bounds, and cannot be partially applied. This is a
much simplified version of expression_of_fn_ptr. *)
let expression_of_fn_op_dynamic (env : env) ({ func; args; dest } : C.call) =
let fHd =
match func with
| C.FnOpDynamic op -> expression_of_operand env op
| _otw ->
failwith @@ "Internal error: the given call is not to `FnOpMove`."
^ "The function `expression_of_fn_op_dynamic` handles only call to `FnOpMove`."
in
let lhs = expression_of_place env dest in
let args = List.map (expression_of_operand env) args in
let args =
if args = [] then
[ Krml.Helpers.eunit ]
else
args
in
(* Asserting that this is not a partial application *)
let ret_t, args_t = Krml.Helpers.flatten_arrow fHd.typ in
assert (List.length args_t = List.length args);
let rhs = K.with_type ret_t @@ K.EApp (fHd, args) in
Krml.Helpers.with_unit @@ K.EAssign (lhs, rhs)
(** Handles only the `SwitchInt` for 128-bit integers. Turn the switch expression into if-then-else
expressions. This is to work around the Krml integer type limitations. *)
let rec expression_of_switch_128bits env ret_var scrutinee branches default : K.expr =
let scrutinee = expression_of_operand env scrutinee in
let else_branch = expression_of_block env ret_var default in
let folder (svs, stmt) else_branch =
(* [i1, i2, ..., in] ==> scrutinee == i1 || scrutinee == i2 || ... || scrutinee == in *)
let guard =
let make_eq sv = mk_op_app Eq scrutinee [ expression_of_scalar_value sv ] in
List.map make_eq svs |> function
| [] -> Krml.Helpers.etrue
| x :: lst -> List.fold_left Krml.Helpers.mk_or x lst
in
(* the "then" body of the if-then-else expression *)
let body = expression_of_block env ret_var stmt in
(* combines the types: compare each branch and then generate the correct type *)
let typ = lesser body.K.typ else_branch.K.typ in
K.(with_type typ (EIfThenElse (guard, body, else_branch)))
in
List.fold_right folder branches else_branch
and expression_of_statement_kind (env : env) (ret_var : C.local_id) (s : C.statement_kind) : K.expr
=
match s with
| Assign (p, rv) ->
let expected_ty = p.ty in
let p = expression_of_place env p in
let rv = expression_of_rvalue env rv expected_ty in
K.(with_type TUnit (EAssign (p, rv)))
| SetDiscriminant (_, _) -> failwith "C.SetDiscriminant"
| StorageLive _ -> Krml.Helpers.eunit
| StorageDead _ -> Krml.Helpers.eunit
| PlaceMention p ->
let p = expression_of_place env p in
K.(with_type TUnit (EIgnore p))
| Drop (p, _, _) ->
let _ = expression_of_place env p in
begin
match p.ty with
(* doesn't do the right thing yet, need to understand why there are
several drops per variable *)
(* | C.Adt (Builtin Vec, _) when false -> *)
(* (1* p is a vec t *1) *)
(* let t = match p.typ with TApp ((["Eurydice"], "vec"), [ t ]) -> t | _ -> assert false in *)
(* Krml.Helpers.(with_unit K.(EApp ( *)
(* with_type (Krml.DeBruijn.subst_tn [ t ] Builtin.vec_drop.typ) (ETApp ( *)
(* with_type Builtin.vec_drop.typ (EQualified Builtin.vec_drop.name), *)
(* [ t ])), *)
(* [ p ]))) *)
| _ -> Krml.Helpers.eunit
end
| Assert (a, _on_failure) -> expression_of_assertion env a
| Call
{
func =
FnOpRegular
{
kind = FunId (FBuiltin ArrayRepeat);
generics = { types = [ ty ]; const_generics = [ c ]; _ };
_;
};
args = [ e ];
dest;
_;
} ->
(* Special treatment *)
let e = expression_of_operand env e in
let t = typ_of_ty env ty in
let t_array = maybe_cg_array env ty c in
let len = expression_of_const_generic env c in
let dest = expression_of_place env dest in
let repeat =
K.(
with_type
(Krml.Helpers.fold_arrow Builtin.array_repeat.cg_args Builtin.array_repeat.typ)
(EQualified Builtin.array_repeat.name))
in
let diff = List.length env.binders - List.length env.cg_binders in
let repeat =
K.(
with_type
Krml.DeBruijn.(subst_t t 0 (subst_ct diff len 0 Builtin.array_repeat.typ))
(ETApp (repeat, [ len ], [], [ t ])))
in
Krml.Helpers.with_unit
K.(
EAssign
( dest,
with_type dest.typ (mk_expr_arr_struct (with_type t_array (EApp (repeat, [ e ])))) ))
| Call
{
func =
FnOpRegular
{
kind = FunId (FBuiltin (Index { is_array = true; mutability = _; is_range = false }));
generics = { types = [ ty ]; const_generics = [ cg ]; _ };
_;
};
args = [ e1; e2 ];
dest;
_;
} ->
(* Special treatment for e1[e2] of array which are translated into struct.
e1[e2] is translated as fn ArrayIndexShared(&[T;N], usize) -> &T
Since [T;N] is translated into arr$T$N, we need to first dereference
the e1 to get the struct, and then take its field "data" to get the
array
We construct dest := &( *e1).data[e2]
*)
let e1 = expression_of_operand env e1 in
let e2 = expression_of_operand env e2 in
let t = typ_of_ty env ty in
let t_array = maybe_cg_array env ty cg in
(* let const = const_of_tbuf e1.K.typ in *)
let e1 = Krml.Helpers.(mk_deref ~const:true (Krml.Helpers.assert_tbuf e1.K.typ) e1.K.node) in
let e1 = K.with_type t_array (K.EField (e1, "data")) in
let dest = expression_of_place env dest in
Krml.Helpers.with_unit
K.(EAssign (dest, addrof ~const:false (with_type t (EBufRead (e1, e2)))))
| Call { func = FnOpRegular fn_ptr; args; dest; _ }
when Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.from_u16 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.from_u32 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.from_u64 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.from_i16 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.from_i32 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.from_i64 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.into_u16 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.into_u32 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.into_u64 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.into_i16 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.into_i32 fn_ptr
|| Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config RustNames.into_i64 fn_ptr
|| false ->
(* TODO: this can now be properly represented in the AST, this should go
away! there is *one* case in Kyber that is not caught by
Cleanup2.remove_trivial_into, and we need to figure out why. *)
let matches p = Charon.NameMatcher.match_fn_ptr env.name_ctx RustNames.config p fn_ptr in
let w : Krml.Constant.width =
if matches RustNames.from_u16 || matches RustNames.into_u16 then
UInt16
else if matches RustNames.from_u32 || matches RustNames.into_u32 then
UInt32
else if matches RustNames.from_u64 || matches RustNames.into_u64 then
UInt64
else if matches RustNames.from_i16 || matches RustNames.into_i16 then
Int16
else if matches RustNames.from_i32 || matches RustNames.into_i32 then
Int32
else if matches RustNames.from_i64 || matches RustNames.into_i64 then
Int64
else
fail "Unknown from-cast: %s" (string_of_fn_ptr env fn_ptr)
in
let dest = expression_of_place env dest in
let e = expression_of_operand env (Krml.KList.one args) in
Krml.Helpers.with_unit K.(EAssign (dest, with_type (TInt w) (ECast (e, TInt w))))
| Call { func = FnOpRegular fn_ptr; args; dest; _ } ->
(* For now, we take trait type arguments to be part of the code-gen *)
let hd, _is_known_builtin, output_t = expression_of_fn_ptr env fn_ptr in
let dest = expression_of_place env dest in
let args = List.map (expression_of_operand env) args in
(* This needs to match what is done in the FunGroup case (i.e. when we extract
a definition). There are two behaviors depending on whether the function is
builtin or not. *)
(* Krml.KPrint.bprintf "Call to %s is builtin %b\n" (string_of_fn_ptr env fn_ptr) is_builtin; *)
let args =
if args = [] then
[ Krml.Helpers.eunit ]
else
args
in
let rhs =
if args = [] then
hd
else
K.with_type output_t (K.EApp (hd, args))
in
(* This does something similar to maybe_addrof *)
let rhs =
(* TODO: determine whether extra_types is necessary *)
let extra_types =
match fn_ptr.kind with
| TraitMethod ({ kind = TraitImpl { id = _; generics }; _ }, _, _) -> generics.types
| _ -> []
in
match fn_ptr.kind, fn_ptr.generics.types @ extra_types with
| ( FunId (FBuiltin (Index { is_array = false; mutability = _; is_range = false })),
[ TSlice _ ] ) ->
(* Will decay. See comment above maybe_addrof *)
rhs
| ( FunId (FBuiltin (Index { is_array = false; mutability = _; is_range = false })),
[ TAdt { id; generics } ] )
when RustNames.is_vec env id generics ->
(* Will decay. See comment above maybe_addrof *)
rhs
| FunId (FBuiltin (Index { is_array = false; mutability = _; is_range = false })), _ ->
K.(with_type (TBuf (rhs.typ, false)) (EAddrOf rhs))
| _ -> rhs
in
Krml.Helpers.with_unit K.(EAssign (dest, rhs))
| Call ({ func = FnOpDynamic _; _ } as call) -> expression_of_fn_op_dynamic env call
| Abort _ -> with_any (K.EAbort (None, Some "panic!"))
| Return ->
let e = expression_of_var_id env ret_var in
K.(with_type TAny (EReturn e))
| Break n ->
assert (n = 0);
K.(with_type TAny EBreak)
| Continue n ->
assert (n = 0);
K.(with_type TAny EContinue)
| Nop -> Krml.Helpers.eunit
| Switch (If (op, s1, s2)) ->
let e1 = expression_of_block env ret_var s1 in
let e2 = expression_of_block env ret_var s2 in
let t = lesser e1.typ e2.typ in
K.(with_type t (EIfThenElse (expression_of_operand env op, e1, e2)))
| Switch (SwitchInt (scrutinee, int_ty, branches, default)) ->
let branches =
List.map
(fun (litl, block) -> List.map Charon.ValuesUtils.literal_as_scalar litl, block)
branches
in
if int_ty = TInt I128 || int_ty = TUInt U128 then
expression_of_switch_128bits env ret_var scrutinee branches default
else
let scrutinee = expression_of_operand env scrutinee in
let branches =
List.concat_map
(fun (svs, stmt) ->
List.map
(fun sv ->
K.SConstant (constant_of_scalar_value sv), expression_of_block env ret_var stmt)
svs)
branches
@ [ K.SWild, expression_of_block env ret_var default ]
in
let t = Krml.KList.reduce lesser (List.map (fun (_, e) -> e.K.typ) branches) in
K.(with_type t (ESwitch (scrutinee, branches)))
| Switch (Match (p, branches, default)) ->
let scrutinee = expression_of_place env p in
let typ_id, typ_lid, variant_name_of_variant_id =
match p.ty with
| TAdt { id = TAdtId typ_id; _ } ->
let ty = env.get_nth_type typ_id in
let variants =
match ty.kind with
| Enum variants -> variants
| _ -> assert false
in
( typ_id,
lid_of_name env ty.item_meta.name,
fun v ->
let v = C.VariantId.nth variants v in
v.variant_name, List.length v.fields )
| _ -> failwith "TODO: match on not adt, not option"
in
let branches =
List.concat_map
(fun (variant_ids, branch) ->
List.map
(fun variant_id ->
let variant_name, n_fields = variant_name_of_variant_id variant_id in
let dummies = List.init n_fields (fun _ -> K.(with_type TAny PWild)) in
let pat =
if is_enum env typ_id then
K.PEnum (mk_enum_case typ_lid variant_name)
else
K.PCons (variant_name, dummies)
in
let pat = K.with_type scrutinee.typ pat in
[], pat, expression_of_block env ret_var branch)
variant_ids)
branches
in
let branches =
branches
@
match default with
| Some default ->
[ [], K.with_type scrutinee.typ K.PWild, expression_of_block env ret_var default ]
| None -> []
in
let t = Krml.KList.reduce lesser (List.map (fun (_, _, e) -> e.K.typ) branches) in
K.(with_type t (EMatch (Unchecked, scrutinee, branches)))
| Loop s -> K.(with_type TUnit (EWhile (Krml.Helpers.etrue, expression_of_block env ret_var s)))
| _ ->
failwith
("Unsupported statement: "
^ Charon.Print.Llbc.statement_kind_to_string env.format_env "" "" s)
and expression_of_statement (env : env) (ret_var : C.local_id) (s : C.statement) : K.expr =
{
(expression_of_statement_kind env ret_var s.kind) with
meta =
(if !Options.comments then
List.map (fun x -> K.CommentBefore x) s.comments_before
else
[]);
}
and expression_of_block (env : env) (ret_var : C.local_id) (b : C.block) : K.expr =
let statements = List.map (expression_of_statement env ret_var) b.statements in
match List.rev statements with
| [] -> Krml.Helpers.eunit
| last :: _ -> K.(with_type last.typ (ESequence statements))
(** Top-level declarations: orchestration *)
let of_declaration_group (dg : 'id C.g_declaration_group) (f : 'id -> 'a) : 'a list =
(* We do not care about recursion as in C, everything is mutually recursive
thanks to header inclusion. *)
match dg with
| NonRecGroup id -> [ f id ]
| RecGroup ids -> List.map f ids
let seen = ref 0
let total = ref 0
(** List all the ids in this declaration group. *)
let declaration_group_to_list (g : C.declaration_group) : C.item_id list =
match g with
| FunGroup g -> List.map (fun id -> C.IdFun id) (C.g_declaration_group_to_list g)
| TypeGroup g -> List.map (fun id -> C.IdType id) (C.g_declaration_group_to_list g)
| GlobalGroup g -> List.map (fun id -> C.IdGlobal id) (C.g_declaration_group_to_list g)
| TraitDeclGroup g -> List.map (fun id -> C.IdTraitDecl id) (C.g_declaration_group_to_list g)
| TraitImplGroup g -> List.map (fun id -> C.IdTraitImpl id) (C.g_declaration_group_to_list g)
| MixedGroup g -> C.g_declaration_group_to_list g
let flags_of_meta (meta : C.item_meta) : K.flags =
[
Krml.Common.Comment
(String.concat "\n"
(List.filter_map
(function
| Charon.Meta.AttrDocComment s -> Some s
| _ -> None)
meta.attr_info.attributes));
]
let decl_of_id (env : env) (id : C.item_id) : K.decl option =
match id with
| IdType id -> begin
let decl = env.get_nth_type id in
let { C.item_meta; def_id; kind; generics = { types = type_params; const_generics; _ }; _ } =
decl
in
let name = item_meta.name in
L.log "AstOfLlbc" "Visiting type: %s\n%s" (string_of_name env name)
(Charon.Print.type_decl_to_string env.format_env decl);
assert (def_id = id);
let name = lid_of_name env name in
let env = push_cg_binders env const_generics in
let env = push_type_binders env type_params in
match kind with
| Union _ | Opaque | TDeclError _ -> None
| Struct fields ->
let fields =
List.mapi
(fun i { C.field_name; field_ty; _ } ->
Some (ensure_named i field_name), (typ_of_ty env field_ty, true))
fields
in
Some
(K.DType (name, [], List.length const_generics, List.length type_params, Flat fields))
| Enum branches when List.for_all (fun v -> v.C.fields = []) branches ->
let has_custom_constants =
let rec has_custom_constants i = function
| { C.discriminant; _ } :: bs ->
Charon.Scalars.get_val (Charon.ValuesUtils.literal_as_scalar discriminant)
<> Z.of_int i
|| has_custom_constants (i + 1) bs
| _ -> false
in
has_custom_constants 0 branches
in
let cases =
List.map
(fun ({ C.variant_name; discriminant; _ } : C.variant) ->
let v =
if has_custom_constants then
Some
(Charon.Scalars.get_val (Charon.ValuesUtils.literal_as_scalar discriminant))
else
None
in
mk_enum_case name variant_name, v)
branches
in
Some (K.DType (name, [], List.length const_generics, List.length type_params, Enum cases))
| Enum branches ->
let branches =
List.map
(fun ({ C.variant_name; fields; _ } : C.variant) ->
( variant_name,
List.mapi
(fun i { C.field_name; field_ty; _ } ->
mk_field_name field_name i, (typ_of_ty env field_ty, true))
fields ))
branches
in
Some
(K.DType
(name, [], List.length const_generics, List.length type_params, Variant branches))
| Alias ty ->
Some
(K.DType
( name,
[],
List.length const_generics,
List.length type_params,
Abbrev (typ_of_ty env ty) ))
end
| IdFun id -> (
let decl = try Some (env.get_nth_function id) with Not_found -> None in
match decl with
| None -> None
| Some decl -> (
let { C.def_id; generics; signature; body; item_meta; src; _ } = decl in
let env = { env with generic_params = generics } in
L.log "AstOfLlbc" "Visiting %sfunction: %s\n%s"
(match body with
| StructuredBody _ -> ""
| _ -> "opaque ")
(string_of_name env item_meta.name)
(Charon.Print.fun_decl_to_string env.format_env " " " " decl);
assert (def_id = id);
let name = lid_of_name env item_meta.name in
match body, src with
| _, TraitDeclItem (_, _, false) ->
(* We skip those on the basis that they generate useless external prototypes, which we
do not really need. *)
None
| ( ( OpaqueBody
| ExternBody _
| IntrinsicBody _
| TraitMethodWithoutDefaultBody
| TargetDispatchBody _
| MissingBody
| ErrorBody _
| UnstructuredBody _ ),
_ ) ->
(* Opaque function *)
let { K.n_cgs; n }, t = typ_of_signature env (C.bound_fun_sig_of_decl decl) in
Some (K.DExternal (None, [], n_cgs, n, name, t, []))
| StructuredBody { locals; body; _ }, _ ->
if Option.is_some decl.is_global_initializer then
None
else
let env = push_cg_binders env generics.const_generics in
let env = push_type_binders env generics.types in
L.log "AstOfLlbc" "ty of locals: %s"
(String.concat " ++ "
(List.map
(fun (local : C.local) ->
Charon.Print.ty_to_string env.format_env local.local_ty)
locals.locals));
L.log "AstOfLlbc" "ty of inputs: %s"
(String.concat " ++ "
(List.map
(fun t -> Charon.Print.ty_to_string env.format_env t)
signature.C.inputs));
(* `locals` contains, in order: special return variable; function arguments;
local variables *)
let args, locals = Krml.KList.split (locals.arg_count + 1) locals.locals in
let return_var = List.hd args in
let args = List.tl args in
let return_type = typ_of_ty env return_var.local_ty in
(* Note: Rust allows zero-argument functions but the krml internal
representation wants a unit there. This is aligned with typ_of_signature. *)
let args =
let t_unit =
C.(
TAdt
{
id = TTuple;
generics =
{ types = []; const_generics = []; regions = []; trait_refs = [] };
})
in
let v_unit =
{
C.index = Charon.Expressions.LocalId.of_int max_int;
name = None;
local_ty = t_unit;
span = decl.item_meta.span;
}
in
if args = [] then
[ v_unit ]
else
args
in
(* At this stage, env has:
cg_binders = <>
type_binders = <>
binders = <>
*)
let clause_binders = mk_clause_binders_and_args env generics.trait_clauses in
debug_trait_clause_mapping env clause_binders;
(* Now we turn it into:
binders = <> ++ <> ++ <>
*)
let env = push_clause_binders env clause_binders in
let env = push_binders env args in
let arg_binders =
List.map
(fun (arg : C.const_generic_param) ->
Krml.Helpers.fresh_binder ~mut:true arg.name (typ_of_ty env arg.ty))
generics.const_generics
@ List.map
(function
| TraitClauseMethod { pretty_name; _ }, t
| TraitClauseConstant { pretty_name; _ }, t ->
Krml.Helpers.fresh_binder pretty_name t
| _ -> assert false)
clause_binders
@ List.map
(fun (arg : C.local) ->
let name = Option.value ~default:"_" arg.name in
Krml.Helpers.fresh_binder ~mut:true name (typ_of_ty env arg.local_ty))
args
in
L.log "AstOfLlbc" "type of binders: %a" ptyps
(List.map (fun o -> o.K.typ) arg_binders);
let body =
with_locals env return_type (return_var :: locals) (fun env ->
expression_of_block env return_var.index body)
in
let flags =
match item_meta.attr_info.inline with
| Some Hint -> [ Krml.Common.Inline ]
| Some Always -> [ Krml.Common.MustInline ]
| Some Never -> [ Krml.Common.NoInline ]
| _ -> []
in
(* This is kind of a hack here: we indicate that this function is intended to be
specialized, at monomorphization-time (which happens quite early on), on the cg
binders but also on the clause binders... This is ok because even though the
clause binders are not in env.cg_binders, well, types don't refer to clause
binders, so we won't have translation errors. *)
let n_cg = List.length generics.const_generics in
let n = List.length generics.types in
Some
(K.DFunction
( None,
flags @ flags_of_meta item_meta,
n_cg,
n,
return_type,
name,
arg_binders,
body ))))
| IdGlobal id ->
let global = env.get_nth_global id in
let { C.item_meta; ty; def_id; _ } = global in
let name = item_meta.name in
let def = env.get_nth_global def_id in
L.log "AstOfLlbc" "Visiting global: %s\n%s" (string_of_name env name)
(Charon.Print.global_decl_to_string env.format_env " " " " def);
let ty = typ_of_ty env ty in
let flags =
[ Krml.Common.Const "" ]
@
match global.global_kind with
| NamedConst | AnonConst ->
(* This is trickier: const can be evaluated at compile-time, so in theory, we could just
emit a macro, except (!) in C, arrays need to be top-level declarations (not macros)
because even with compound literals, you can't do `((int[1]){0})[0]` in expression
position.
We can't use the test "is_bufcreate" because the expression might only be a bufcreate
*after* simplification, so we rely on the type here. *)
if Krml.Helpers.is_array ty then
[]
else
[ Macro ]
| Static ->
(* This one needs to have an address, so definitely not emitting it as a macro. *)
[]
in
let body = env.get_nth_function def.init in
L.log "AstOfLlbc" "Corresponding body:%s"
(Charon.Print.fun_decl_to_string env.format_env " " " " body);
begin
match body.body with
| StructuredBody body ->
let ret_var = List.hd body.locals.locals in
let body =
with_locals env ty body.locals.locals (fun env ->
expression_of_block env ret_var.index body.body)
in
Some (K.DGlobal (flags, lid_of_name env name, 0, ty, body))
| _ -> Some (K.DExternal (None, [], 0, 0, lid_of_name env name, ty, []))
end
| IdTraitDecl _ | IdTraitImpl _ -> None
let name_of_id env (id : C.item_id) =
match id with
| IdType id -> (env.get_nth_type id).item_meta.name
| IdFun id -> (env.get_nth_function id).item_meta.name
| IdGlobal id -> (env.get_nth_global id).item_meta.name
| _ -> failwith "unsupported"
let known_failures =
List.map Charon.NameMatcher.parse_pattern
[
(* Failure("TODO: TraitTypes Self::Output") *)
"core::array::{core::ops::index::Index<[@T; @N], @I, @C>}::index";
(* Failure("TODO: TraitTypes parent(Self)::TraitClause@0::Output") *)
"core::array::{core::ops::index::IndexMut<[@T; @N], @I, @C>}::index_mut";
(* Failure("TODO: TraitTypes core::marker::DiscriminantKind::Discriminant") *)
"core::intrinsics::discriminant_value";
(* Failure("TODO: TraitTypes Self::Output") *)
"core::slice::index::{core::ops::index::Index<[@T], @I, @C>}::index";
(* Failure("TODO: TraitTypes Self::Output") *)
"core::slice::index::{core::ops::index::IndexMut<[@T], @I, @C>}::index_mut";
(* File "lib/AstOfLlbc.ml", line 389, characters 6-12: Assertion failed *)
"core::slice::index::{core::slice::index::SliceIndex, [@T], \
[@T]>}::get_unchecked";
(* File "lib/AstOfLlbc.ml", line 389, characters 6-12: Assertion failed *)
"core::slice::index::{core::slice::index::SliceIndex, [@T], \
[@T]>}::get_unchecked_mut";
(* File "lib/AstOfLlbc.ml", line 389, characters 6-12: Assertion failed *)
"core::slice::index::{core::slice::index::SliceIndex, \
[@T], [@T]>}::get_unchecked";
(* File "lib/AstOfLlbc.ml", line 389, characters 6-12: Assertion failed *)
"core::slice::index::{core::slice::index::SliceIndex, \
[@T], [@T]>}::get_unchecked_mut";
(* File "lib/AstOfLlbc.ml", line 389, characters 6-12: Assertion failed *)
"core::slice::index::{core::slice::index::SliceIndex, [@T], \
[@T]>}::get_unchecked";
(* File "lib/AstOfLlbc.ml", line 389, characters 6-12: Assertion failed *)
"core::slice::index::{core::slice::index::SliceIndex, [@T], \
[@T]>}::get_unchecked_mut";
(* Failure("TODO: TraitTypes core::marker::DiscriminantKind::Discriminant") *)
"issue_123::{core::cmp::PartialEq}::eq";
(* Failure("Can't handle arbitrary closures") *)
"mismatch::{mismatch::MlKemKeyPairUnpacked<@Vector, @K>}::default";
]
let replacements =
List.map
(fun (p, d) -> Charon.NameMatcher.parse_pattern p, d)
[
"core::result::{core::result::Result<@T, @E>}::unwrap", Builtin.unwrap;
"core::slice::{[@T]}::swap", Builtin.slice_swap;
"alloc::vec::{alloc::vec::Vec<@T>}::try_with_capacity", Builtin.try_with_capacity;
"core::ptr::null_mut", Builtin.null_mut;
]
(* Catch-all error handler (last resort) *)
let decl_of_id env decl =
match
List.find_map
(fun (p, d) ->
match
Charon.NameMatcher.match_name env.name_ctx RustNames.config p (name_of_id env decl)
with
| true -> Some d
| false -> None
| exception _ -> None)
replacements
with
| Some d ->
let lid = lid_of_name env (name_of_id env decl) in
L.log "AstOfLlbc" "Found replacement for %a" plid lid;
Some (d lid)
| None -> (
try decl_of_id env decl
with e ->
let matches p =
Charon.NameMatcher.match_name env.name_ctx RustNames.config p (name_of_id env decl)
in
if not (List.exists matches known_failures) then begin
Printf.eprintf "ERROR translating %s: %s\n%s"
(string_of_pattern (pattern_of_name env (name_of_id env decl)))
(Printexc.to_string e) (Printexc.get_backtrace ());
if not !Options.keep_going then
exit 255
else
None
end
else
None)
let flatten_declarations (d : C.declaration_group list) : C.item_id list =
List.flatten (List.map declaration_group_to_list d)
let decls_of_declarations (env : env) (d : C.item_id list) : K.decl list =
incr seen;
L.log "Progress" "%s: %d/%d" env.crate_name !seen !total;
Krml.KList.filter_some @@ List.map (decl_of_id env) d
(*
let impl_obligation (ob: decl_obligation) : K.decl =
match ob with ObliArray (lid, t_array) ->
L.log "AstOfLlbc" "append new decl of struct: %a" plid lid;
K.DType (lid, [], 1, 1, Flat [(Some "data",(t_array,true))])
let impl_obligations (obpairs : (decl_obligation * unit) list) : K.decl list =
List.map impl_obligation (List.map fst obpairs)
*)
let file_of_crate (crate : Charon.LlbcAst.crate) : Krml.Ast.file =
let {
C.name;
declarations;
type_decls;
fun_decls;
global_decls;
trait_decls;
trait_impls;
options;
_;
} =
crate
in
if options.preset <> Some Eurydice then begin
Printf.eprintf "ERROR: Eurydice expects Charon to be invoked with `--preset=eurydice`\n";
exit 255
end;
let declarations = flatten_declarations declarations in
seen := 0;
total := List.length declarations;
let format_env = Charon.Print.crate_to_fmt_env crate in
let get_nth_function id =
match C.FunDeclId.Map.find_opt id fun_decls with
| Some f -> f
| None -> fail "Function id not found: %s" (Charon.Print.fun_decl_id_to_string format_env id)
in
let get_nth_type id =
match C.TypeDeclId.Map.find_opt id type_decls with
| Some ty -> ty
| None -> fail "Type id not found: %s" (Charon.Print.type_decl_id_to_string format_env id)
in
let get_nth_global id =
match C.GlobalDeclId.Map.find_opt id global_decls with
| Some g -> g
| None -> fail "Global id not found: %s" (Charon.Print.global_decl_id_to_string format_env id)
in
let get_nth_trait_impl id =
match C.TraitImplId.Map.find_opt id trait_impls with
| Some impl -> impl
| None ->
fail "Trait impl id not found: %s" (Charon.Print.trait_impl_id_to_string format_env id)
in
let get_nth_trait_decl id =
match C.TraitDeclId.Map.find_opt id trait_decls with
| Some decl -> decl
| None ->
fail "Trait decl id not found: %s" (Charon.Print.trait_decl_id_to_string format_env id)
in
let name_ctx = Charon.NameMatcher.ctx_from_crate crate in
let env =
{
get_nth_function;
get_nth_type;
get_nth_global;
get_nth_trait_impl;
get_nth_trait_decl;
crate;
cg_binders = [];
binders = [];
type_binders = [];
format_env;
crate_name = name;
name_ctx;
generic_params = Charon.TypesUtils.empty_generic_params;
}
in
let trans_decls = decls_of_declarations env declarations in
let extra_decls = Builtin.[ dst_ref_shared_decl; dst_ref_mut_decl; decl_of_arr ] in
name, trans_decls @ extra_decls
================================================
FILE: lib/Builtin.ml
================================================
module K = struct
include Krml.Ast
end
(** 1. Things that could otherwise be emitted as an extern prototype, but for some reason ought to
be skipped. This is used by main.ml *)
let skip = Krml.Idents.LidSet.of_list [ [ "Eurydice" ], "assert"; [], "UNIT_METADATA" ]
(** 2. Internal types; this is the equivalent of an abstract type *)
let char_t = K.(TInt UInt32)
let c_void_t = K.TQualified ([ "Eurydice" ], "c_void_t")
let c_char_t = K.TQualified ([ "Eurydice" ], "c_char_t")
let int128_t = K.TQualified ([ "Eurydice"; "Int128" ], "int128_t")
let uint128_t = K.TQualified ([ "Eurydice"; "Int128" ], "uint128_t")
(** 3. Types that we *define* in abstract syntax, and associated helpers. *)
(** Dynamically-sized types. *)
let dst_ref_shared = [ "Eurydice" ], "dst_ref_shared"
let dst_ref_shared_decl =
K.DType
( dst_ref_shared,
[],
0,
2,
Flat [ Some "ptr", (TBuf (TBound 1, true), false); Some "meta", (TBound 0, false) ] )
let dst_ref_mut = [ "Eurydice" ], "dst_ref_mut"
let dst_ref_mut_decl =
K.DType
( dst_ref_mut,
[],
0,
2,
Flat [ Some "ptr", (TBuf (TBound 1, false), false); Some "meta", (TBound 0, false) ] )
let mk_dst_ref ~const (t : K.typ) (meta : K.typ) : K.typ =
let const =
if !Options.no_const then
false
else
const
in
K.TApp
( (if const then
dst_ref_shared
else
dst_ref_mut),
[ t; meta ] )
let mk_slice ~const (t : K.typ) : K.typ = mk_dst_ref ~const t (TInt SizeT)
(* Take the type of the ptr field *)
let dst_new ~const ~ptr ~len t =
let open K in
with_type (mk_slice ~const t) (EFlat [ Some "ptr", ptr; Some "meta", len ])
(* Arrays, as values.
Special treatment for the array type: translating [T;C] as rust generic type
struct { data : [T;C]; } *)
let arr : K.lident = [ "Eurydice" ], "arr"
let mk_arr (t : K.typ) (cg : K.cg) : K.typ = K.TCgApp (K.TApp (arr, [ t ]), cg)
(* [] : no flags
1 : we have one const generic C
1 : we have one type argument T *)
let decl_of_arr = K.DType (arr, [], 1, 1, Flat [ Some "data", (K.TCgArray (TBound 0, 0), true) ])
(* a->data where a: Arr*, to be used before eurydice monomorphization *)
let data_of_arrref ?const (arrref : K.expr) t n_cgid =
let arr =
Krml.Helpers.(mk_deref ?const (Krml.Helpers.assert_tbuf_or_tarray arrref.typ) arrref.node)
in
K.(with_type (TCgArray (t, n_cgid)) (EField (arr, "data")))
let c_string_def =
K.DType (([ "Prims" ], "string"), [ Private ], 0, 0, Abbrev (TBuf (c_char_t, false)))
let nonzero = [ "core"; "num"; "nonzero" ], "NonZero"
let nonzero_def = K.DType (nonzero, [], 0, 1, Abbrev (TBound 0))
let mk_nonzero t = K.TApp (nonzero, [ t ])
(* 4. Helpers to build types that are either eliminated, implemented as macros, or are generated by
the translation. *)
let derefed_slice = [ "Eurydice" ], "derefed_slice"
(** The C counterpart of `&str` *)
let str_t ~const = mk_dst_ref ~const c_char_t (TInt SizeT)
(** The C counterpart of `str` and serves twofold functionalities: (1) when in expressions, it
serves as a placeholder to get referenced again; (2) when in customised DST definition, it is
defined as [char []] to have 0-length. *)
let deref_str_t = K.TApp (derefed_slice, [ c_char_t ])
let vec : K.lident = [ "Eurydice" ], "vec"
let mk_vec (t : K.typ) : K.typ = K.TApp (vec, [ t ])
let range : K.lident = [ "core"; "ops"; "range" ], "Range"
let mk_range (t : K.typ) : K.typ = K.TApp (range, [ t ])
let range_to : K.lident = [ "core"; "ops"; "range" ], "RangeTo"
let mk_range_to (t : K.typ) : K.typ = K.TApp (range_to, [ t ])
let range_from : K.lident = [ "core"; "ops"; "range" ], "RangeFrom"
let mk_range_from (t : K.typ) : K.typ = K.TApp (range_from, [ t ])
let option : K.lident = [ "core"; "option" ], "Option"
let mk_option (t : K.typ) : K.typ = K.TApp (option, [ t ])
let result = [ "core"; "result" ], "Result"
let mk_result t1 t2 = K.TApp (result, [ t1; t2 ])
let mk_sizeT = K.with_type (TInt SizeT)
let iterator : K.lident = [ "core"; "iter"; "traits"; "iterator" ], "Iterator"
let mk_iterator t = K.TApp (iterator, [ t ])
let step_by : K.lident = [ "core"; "iter"; "adapters"; "step_by" ], "StepBy"
let mk_step_by t = K.TApp (step_by, [ t ])
let mk_range_step_by_iterator t = mk_iterator (mk_step_by t)
let layout_t = K.TQualified ([ "core"; "alloc"; "layout" ], "Layout")
(** 5. A list of known builtins, i.e. functions that we intend to implement as macros, or eliminate
later on. Some of these are markers inserted by AstOfLlbc, and destined to be eliminated later
through targeted phases. *)
type builtin = {
name : K.lident;
typ : K.typ;
n_type_args : int;
cg_args : K.typ list;
arg_names : string list;
}
(** A record to hold a builtin *function* with all relevant information for both krml and the
transpilation phase in AstOfLlbc *)
let expr_of_builtin { name; typ; cg_args; _ } =
(* let open Krml in *)
(* let open PrintAst.Ops in *)
(* KPrint.bprintf "%a:\n typ = %a\n cg_args=%a\n\n" plid name ptyp typ ptyps cg_args; *)
let typ = List.fold_right (fun t acc -> K.TArrow (t, acc)) cg_args typ in
K.(with_type typ (EQualified name))
let chop_cg_args n t =
let t, ts = Krml.Helpers.flatten_arrow t in
let _, ts = Krml.KList.split n ts in
let t = Krml.Helpers.fold_arrow ts t in
t
let expr_of_builtin_t builtin ?(cgs = 0, []) ts =
let open Krml.DeBruijn in
let builtin = expr_of_builtin builtin in
let diff, cg_exprs = cgs in
let cgs = List.map (cg_of_expr diff) cg_exprs in
let t = chop_cg_args (List.length cgs) (subst_tn ts (subst_ctn' cgs builtin.typ)) in
K.(with_type t (ETApp (builtin, cg_exprs, [], ts)))
module Op128Map = Map.Make (struct
type t = string * string
let compare = Stdlib.compare
end)
(* Builtins for i128 and u128 are defined here but implemented in C. *)
let mk_128_builtin_op kind op lhs_typ rhs_typ ret_typ =
let name = [ "Eurydice"; "Int128" ], kind ^ "128_" ^ op in
let args, arg_names =
match rhs_typ with
| K.TUnit -> [ lhs_typ ], [ "lhs" ]
| rhs -> [ lhs_typ; rhs ], [ "lhs"; "rhs" ]
in
{ name; typ = Krml.Helpers.fold_arrow args ret_typ; n_type_args = 0; cg_args = []; arg_names }
let op_128_cfgs =
[
("i", "from_bits"), (Krml.Helpers.uint64, Krml.Helpers.uint64, int128_t);
("i", "add"), (int128_t, int128_t, int128_t);
("i", "sub"), (int128_t, int128_t, int128_t);
("i", "mul"), (int128_t, int128_t, int128_t);
("i", "div"), (int128_t, int128_t, int128_t);
("i", "mod"), (int128_t, int128_t, int128_t);
("i", "bor"), (int128_t, int128_t, int128_t);
("i", "band"), (int128_t, int128_t, int128_t);
("i", "bxor"), (int128_t, int128_t, int128_t);
("i", "shl"), (int128_t, TInt UInt32, int128_t);
("i", "shr"), (int128_t, TInt UInt32, int128_t);
("i", "bnot"), (int128_t, K.TUnit, int128_t);
("i", "neg"), (int128_t, K.TUnit, int128_t);
("u", "neg"), (uint128_t, K.TUnit, uint128_t);
("i", "eq"), (int128_t, int128_t, TBool);
("i", "lt"), (int128_t, int128_t, TBool);
("i", "gt"), (int128_t, int128_t, TBool);
("i", "lte"), (int128_t, int128_t, TBool);
("i", "gte"), (int128_t, int128_t, TBool);
("i", "neq"), (int128_t, int128_t, TBool);
("i", "addW"), (int128_t, int128_t, int128_t);
("i", "subW"), (int128_t, int128_t, int128_t);
("i", "divW"), (int128_t, int128_t, int128_t);
("i", "multW"), (int128_t, int128_t, int128_t);
("u", "from_bits"), (Krml.Helpers.uint64, Krml.Helpers.uint64, uint128_t);
("u", "add"), (uint128_t, uint128_t, uint128_t);
("u", "sub"), (uint128_t, uint128_t, uint128_t);
("u", "mul"), (uint128_t, uint128_t, uint128_t);
("u", "div"), (uint128_t, uint128_t, uint128_t);
("u", "mod"), (uint128_t, uint128_t, uint128_t);
("u", "bor"), (uint128_t, uint128_t, uint128_t);
("u", "band"), (uint128_t, uint128_t, uint128_t);
("u", "bxor"), (uint128_t, uint128_t, uint128_t);
("u", "shl"), (uint128_t, TInt UInt32, uint128_t);
("u", "shr"), (uint128_t, TInt UInt32, uint128_t);
("u", "bnot"), (uint128_t, K.TUnit, uint128_t);
("u", "eq"), (uint128_t, uint128_t, TBool);
("u", "lt"), (uint128_t, uint128_t, TBool);
("u", "gt"), (uint128_t, uint128_t, TBool);
("u", "lte"), (uint128_t, uint128_t, TBool);
("u", "gte"), (uint128_t, uint128_t, TBool);
("u", "neq"), (uint128_t, uint128_t, TBool);
("u", "addW"), (uint128_t, uint128_t, uint128_t);
("u", "subW"), (uint128_t, uint128_t, uint128_t);
("u", "divW"), (uint128_t, uint128_t, uint128_t);
("u", "multW"), (uint128_t, uint128_t, uint128_t);
]
|> List.fold_left
(fun acc ((kind, op), (lhs_typ, rhs_typ, ret_typ)) ->
Op128Map.add (kind, op) (mk_128_builtin_op kind op lhs_typ rhs_typ ret_typ) acc)
Op128Map.empty
let get_128_op (kind, op) : K.expr = expr_of_builtin @@ Op128Map.find (kind, op) op_128_cfgs
(** Get the size of the given type, corresponding to `sizeof` in C. This corresponds to
`NullOp::SizeOf` in Charon, which is itself used in metadata field `size` in vtable. *)
let sizeof =
{
name = [ "Eurydice" ], "sizeof";
typ = Krml.Helpers.fold_arrow [] (TInt SizeT);
n_type_args = 1;
cg_args = [];
arg_names = [];
}
(** Get the alignment of the given type, corresponding to `alignof` in C. This corresponds to
`NullOp::AlignOf` in Charon, which is itself used in metadata field `align` in vtable. *)
let alignof =
{
name = [ "Eurydice" ], "alignof";
typ = Krml.Helpers.fold_arrow [] (TInt SizeT);
n_type_args = 1;
cg_args = [];
arg_names = [];
}
let suffix_of_const const =
if const then
"_shared"
else
"_mut"
(* These two are placeholders that are inserted by AstOfLlbc with the intent that they should be
desugared later on, once monomorphization and data type compilation, respectively, have happened. *)
let array_repeat =
{
name = [ "Eurydice" ], "array_repeat";
typ = Krml.Helpers.fold_arrow [ TBound 0 ] (TCgArray (TBound 0, 0));
n_type_args = 1;
cg_args = [ TInt SizeT ];
arg_names = [ "init" ];
}
(* Eurydice_discriminant(x: T) -> U
T = type of the argument (an ADT)
U = expected type of the discriminant (usize, u8, etc.)
There is an unverified invariant that the algorithm in CStarToC11 to automatically pick suitable
sizes for the `tag` field is compatible with the expected type U here. *)
let discriminant =
{
name = [ "Eurydice" ], "discriminant";
typ = Krml.Helpers.fold_arrow [ TBound 1 ] (TBound 0);
n_type_args = 2;
cg_args = [];
arg_names = [ "adt" ];
}
let array_eq =
{
name = [ "Eurydice" ], "array_eq";
typ =
Krml.Helpers.fold_arrow
[ TBuf (mk_arr (TBound 0) (CgVar 0), true); TBuf (mk_arr (TBound 0) (CgVar 0), true) ]
TBool;
n_type_args = 1;
cg_args = [ TInt SizeT ];
arg_names = [ "arr"; "arr2" ];
}
let array_eq_slice const =
{
name = [ "Eurydice" ], "array_eq_slice" ^ suffix_of_const const;
typ =
Krml.Helpers.fold_arrow
[ TBuf (mk_arr (TBound 0) (CgVar 0), true); TBuf (mk_slice ~const (TBound 0), true) ]
TBool;
n_type_args = 1;
cg_args = [ TInt SizeT ];
arg_names = [ "arr"; "slice" ];
}
(* Unlike other builtins in this file, comparing an array for
equality with a slice has a single implementation in Rust.
It should, by default, take a const pointer to the slice,
on the basis that the callee does not modify its argument.
However, when `--no-const` is passed as an option, we pick a
variant that takes a mutable slice so as to avoid generating
const slice types. *)
let array_eq_slice_shared = array_eq_slice true
let array_eq_slice_mut = array_eq_slice false
let slice_eq const =
{
name = [ "Eurydice" ], "slice_eq" ^ suffix_of_const const;
typ =
Krml.Helpers.fold_arrow
[ TBuf (mk_slice ~const (TBound 0), true); TBuf (mk_slice ~const (TBound 0), true) ]
TBool;
n_type_args = 1;
cg_args = [];
arg_names = [ "s1"; "s2" ];
}
let slice_eq_shared = slice_eq true
let slice_eq_mut = slice_eq false
(* XXX investigate whether this can be extracted now...?
This is incorrect: the function receives e.g.
- Range as its type argument,
- &StepBy> for the type of its argument,
then returns Option for its return value. Which we can't really type. *)
let range_iterator_step_by =
{
name = [ "Eurydice" ], "range_iterator_step_by";
typ =
Krml.Helpers.fold_arrow [ mk_range (TBound 0); TInt SizeT ] (mk_step_by (mk_range (TBound 0)));
n_type_args = 1;
cg_args = [];
arg_names = [ "iter" ];
}
let range_step_by_iterator_next =
{
name = [ "Eurydice" ], "range_step_by_iterator_next";
typ =
Krml.Helpers.fold_arrow
[ TBuf (mk_step_by (mk_range (TBound 0)), false) ]
(mk_option (TBound 0));
n_type_args = 1;
cg_args = [];
arg_names = [ "iter" ];
}
let slice_index const =
{
name = [ "Eurydice" ], "slice_index" ^ suffix_of_const const;
typ = Krml.Helpers.fold_arrow [ mk_slice ~const (TBound 0); TInt SizeT ] (TBound 0);
n_type_args = 1;
cg_args = [];
arg_names = [ "s"; "i" ];
}
let slice_index_shared = slice_index true
let slice_index_mut = slice_index false
(* The three entries below do not need a shared/mut variant because of the way the &mut[T] vs &[T]
is passed as an argument to the type application *)
(* This is replaced in PreCleanup because we need to allocate a Arr *)
let slice_to_array =
{
name = [ "Eurydice" ], "slice_to_array";
typ = Krml.Helpers.fold_arrow [ TBound 2 ] (mk_result (TBound 1) (TBound 0));
n_type_args = 3;
cg_args = [];
arg_names = [ "s" ];
}
(* This is replaced by slice_to_ref_array2 by allocate a Arr and pass the ref as arg*)
let slice_to_ref_array =
{
name = [ "Eurydice" ], "slice_to_ref_array";
typ = Krml.Helpers.fold_arrow [ TBound 2 ] (mk_result (TBound 1) (TBound 0));
n_type_args = 3;
cg_args = [ TInt SizeT ];
arg_names = [ "s" ];
}
let slice_to_ref_array2 =
{
name = [ "Eurydice" ], "slice_to_ref_array2";
typ = Krml.Helpers.fold_arrow [ TBound 2; TBound 1 ] (mk_result (TBound 1) (TBound 0));
n_type_args = 3;
cg_args = [ TInt SizeT ];
arg_names = [ "s" ];
}
let box_new =
{
name = [ "Eurydice" ], "box_new";
typ = Krml.Helpers.fold_arrow [ TBound 0 ] (TBuf (TBound 0, false));
n_type_args = 1;
cg_args = [];
arg_names = [ "v" ];
}
let empty_array =
{
name = [ "Eurydice" ], "empty_array";
typ = Krml.Helpers.fold_arrow [ TBound 0 ] (mk_arr (TBound 0) (CgConst (SizeT, "0")));
n_type_args = 1;
cg_args = [];
arg_names = [ "x" ];
}
let replace =
{
name = [ "Eurydice" ], "replace";
typ = Krml.Helpers.fold_arrow [ TBuf (TBound 0, false); TBound 0 ] (TBound 0);
n_type_args = 1;
cg_args = [];
arg_names = [ "v"; "x" ];
}
(* pointer, value *)
let bitand_pv_u8 =
{
name = [ "Eurydice" ], "bitand_pv_u8";
typ = Krml.Helpers.fold_arrow [ TBuf (TInt UInt8, false); TInt UInt8 ] (TInt UInt8);
n_type_args = 0;
cg_args = [];
arg_names = [ "x"; "y" ];
}
let shr_pv_u8 =
{
name = [ "Eurydice" ], "shr_pv_u8";
typ = Krml.Helpers.fold_arrow [ TBuf (TInt UInt8, false); TInt Int32 ] (TInt UInt8);
n_type_args = 0;
cg_args = [];
arg_names = [ "x"; "y" ];
}
let min_u32 =
{
name = [ "Eurydice" ], "min_u32";
typ = Krml.Helpers.fold_arrow [ TInt UInt32; TInt UInt32 ] (TInt UInt32);
n_type_args = 0;
cg_args = [];
arg_names = [ "x"; "y" ];
}
(* A non error-checking function that returns a vector whose ptr component is potentially NULL *)
let vec_alloc =
{
name = [ "Eurydice" ], "vec_alloc";
typ = Krml.Helpers.fold_arrow [ TInt SizeT ] (mk_vec (TBound 0));
n_type_args = 1;
cg_args = [];
arg_names = [ "len" ];
}
(* Will allocating len elements of type T overflow SIZE_MAX? *)
let vec_overflows =
{
name = [ "Eurydice" ], "vec_overflows";
typ = Krml.Helpers.fold_arrow [ TInt SizeT ] TBool;
n_type_args = 1;
cg_args = [];
arg_names = [ "len" ];
}
(* Since Eurydice_vec is opaque from the point of view of krml, we expose a helper (implemented with
a macro) that can determine whether this a failed allocation *)
let vec_failed =
{
name = [ "Eurydice" ], "vec_failed";
typ = Krml.Helpers.fold_arrow [ mk_vec (TBound 0) ] TBool;
n_type_args = 1;
cg_args = [];
arg_names = [ "v" ];
}
(* Compute a layout from a type *)
let layout =
{
name = [ "Eurydice" ], "layout";
typ = Krml.Helpers.fold_arrow [ TUnit ] layout_t;
n_type_args = 1;
cg_args = [];
arg_names = [];
}
(* 6. Implementations, defined as DFunction using abstract syntax.
We still provide a corresponding `builtin` to facilitate interop between AstOfLlbc and later phases
-- we still need to convey type information for AstOfLlbc to generate well-typed nodes. *)
(* Helpers for common use *)
(* let array_to_slice (a : &Arr) = dst_ref { ptr = a->data; meta = N } *)
let array_to_slice_func const =
let open Krml in
let open Ast in
let element_t = TBound 0 in
let arrref_t = TBuf (mk_arr (TBound 0) (CgVar 0), const) in
let ret_t = mk_slice ~const element_t in
let lid = [ "Eurydice" ], "array_to_slice" ^ suffix_of_const const in
let binders = [ Helpers.fresh_binder "N" (TInt SizeT); Helpers.fresh_binder "a" arrref_t ] in
let expr =
(* args *)
let n = mk_sizeT (EBound 1) in
let arrref = with_type arrref_t (EBound 0) in
let data = data_of_arrref ~const:true arrref element_t 0 in
with_type ret_t (EFlat [ Some "ptr", data; Some "meta", n ])
in
DFunction (None, [ Private ], 1, 1, ret_t, lid, binders, expr)
let array_to_slice_func_shared = array_to_slice_func true
let array_to_slice_func_mut = array_to_slice_func false
(* let array_to_subslice (r: Range, x : &Arr)
= dst_ref { ptr = a->data + r.start ; meta = r.end - r.start } *)
let array_to_subslice_func const =
let open Krml in
let open Ast in
let element_t = TBound 2 in
let arrref_t = TBuf (mk_arr (TBound 2) (CgVar 0), const) in
let ret_t = mk_slice ~const element_t in
let lid = [ "Eurydice" ], "array_to_subslice" ^ suffix_of_const const in
let binders =
[
Helpers.fresh_binder "N" (TInt SizeT);
Helpers.fresh_binder "a" arrref_t;
Helpers.fresh_binder "r" (mk_range (TInt SizeT));
]
in
let expr =
(* args *)
let arrref = with_type arrref_t (EBound 1) in
let range = with_type (mk_range (TInt SizeT)) (EBound 0) in
let data = data_of_arrref ~const:true arrref element_t 0 in
let r_start = mk_sizeT (EField (range, "start")) in
let r_end = mk_sizeT (EField (range, "end")) in
let meta = mk_sizeT (EApp (Helpers.mk_op Sub (TInt SizeT), [ r_end; r_start ])) in
let ptr = with_type (TBuf (element_t, const)) (EBufSub (data, r_start)) in
with_type ret_t (EFlat [ Some "ptr", ptr; Some "meta", meta ])
in
DFunction (None, [ Private ], 1, 3, ret_t, lid, binders, expr)
let array_to_subslice_func_shared = array_to_subslice_func true
let array_to_subslice_func_mut = array_to_subslice_func false
(* let array_to_subslice_to (r: RangeTo, x : &Arr)
= dst_ref { ptr = a->data; meta = r.end } *)
let array_to_subslice_to_func const =
let open Krml in
let open Ast in
let element_t = TBound 2 in
let arrref_t = TBuf (mk_arr (TBound 2) (CgVar 0), const) in
let ret_t = mk_slice ~const element_t in
let lid = [ "Eurydice" ], "array_to_subslice_to" ^ suffix_of_const const in
let binders =
[
Helpers.fresh_binder "N" (TInt SizeT);
Helpers.fresh_binder "a" arrref_t;
Helpers.fresh_binder "r" (mk_range_to (TInt SizeT));
]
in
let expr =
(* args *)
let arrref = with_type arrref_t (EBound 1) in
let range = with_type (mk_range_to (TInt SizeT)) (EBound 0) in
(* { .ptr = a->data + r.start, .meta = r.end - r.start }*)
let data = data_of_arrref ~const:true arrref element_t 0 in
let meta = with_type (TInt SizeT) (EField (range, "end")) in
with_type ret_t (EFlat [ Some "ptr", data; Some "meta", meta ])
in
DFunction (None, [ Private ], 1, 3, ret_t, lid, binders, expr)
let array_to_subslice_to_func_shared = array_to_subslice_to_func true
let array_to_subslice_to_func_mut = array_to_subslice_to_func false
(* let array_to_subslice_from (r: RangeFrom, x : &Arr)
= dst_ref { ptr = a->data + r.start; meta = N - r.start } *)
let array_to_subslice_from_func const =
let open Krml in
let open Ast in
let element_t = TBound 2 in
let arrref_t = TBuf (mk_arr (TBound 2) (CgVar 0), const) in
let ret_t = mk_slice ~const element_t in
let lid = [ "Eurydice" ], "array_to_subslice_from" ^ suffix_of_const const in
let binders =
[
Helpers.fresh_binder "N" (TInt SizeT);
Helpers.fresh_binder "a" arrref_t;
Helpers.fresh_binder "r" (mk_range_from (TInt SizeT));
]
in
let expr =
(* args *)
let n = mk_sizeT (EBound 2) in
let arrref = with_type arrref_t (EBound 1) in
let range = with_type (mk_range_from (TInt SizeT)) (EBound 0) in
let data = data_of_arrref ~const:true arrref element_t 0 in
let start = mk_sizeT (EField (range, "start")) in
let meta = mk_sizeT (EApp (Helpers.mk_op Sub (TInt SizeT), [ n; start ])) in
let ptr = with_type (TBuf (element_t, const)) (EBufSub (data, start)) in
with_type ret_t (EFlat [ Some "ptr", ptr; Some "meta", meta ])
in
DFunction (None, [ Private ], 1, 3, ret_t, lid, binders, expr)
let array_to_subslice_from_func_shared = array_to_subslice_from_func true
let array_to_subslice_from_func_mut = array_to_subslice_from_func false
(* let slice_subslice (r: Range, s : DstRef)
= dst_ref { ptr = s.ptr + r.start; meta = r.end - r.start } *)
let slice_subslice_func const =
let open Krml in
let open Ast in
let element_t = TBound 2 in
let slice_t = mk_slice ~const element_t in
let lid = [ "Eurydice" ], "slice_subslice" ^ suffix_of_const const in
let binders =
[ Helpers.fresh_binder "s" slice_t; Helpers.fresh_binder "r" (mk_range (TInt SizeT)) ]
in
let expr =
(* args *)
let slice = with_type slice_t (EBound 1) in
let range = with_type (mk_range (TInt SizeT)) (EBound 0) in
let ptr = with_type (TBuf (element_t, const)) (EField (slice, "ptr")) in
let r_start = mk_sizeT (EField (range, "start")) in
let r_end = mk_sizeT (EField (range, "end")) in
let meta = mk_sizeT (EApp (Helpers.mk_op Sub (TInt SizeT), [ r_end; r_start ])) in
let ptr = with_type (TBuf (element_t, const)) (EBufSub (ptr, r_start)) in
with_type slice_t (EFlat [ Some "ptr", ptr; Some "meta", meta ])
in
DFunction (None, [ Private ], 0, 3, slice_t, lid, binders, expr)
let slice_subslice_func_shared = slice_subslice_func true
let slice_subslice_func_mut = slice_subslice_func false
(* let slice_subslice_to (r: RangeTo, s : DstRef)
= dst_ref { ptr = s.ptr ; meta = r.end } *)
let slice_subslice_to_func const =
let open Krml in
let open Ast in
let element_t = TBound 2 in
let slice_t = mk_slice ~const element_t in
let lid = [ "Eurydice" ], "slice_subslice_to" ^ suffix_of_const const in
let binders =
[ Helpers.fresh_binder "s" slice_t; Helpers.fresh_binder "r" (mk_range_to (TInt SizeT)) ]
in
let expr =
(* args *)
let slice = with_type slice_t (EBound 1) in
let range = with_type (mk_range_to (TInt SizeT)) (EBound 0) in
let ptr = with_type (TBuf (element_t, const)) (EField (slice, "ptr")) in
let meta = with_type (TInt SizeT) (EField (range, "end")) in
with_type slice_t (EFlat [ Some "ptr", ptr; Some "meta", meta ])
in
DFunction (None, [ Private ], 0, 3, slice_t, lid, binders, expr)
let slice_subslice_to_func_shared = slice_subslice_to_func true
let slice_subslice_to_func_mut = slice_subslice_to_func false
(* let slice_subslice_from (r: RangeFrom, s : DstRef)
= dst_ref { ptr = s.ptr + r.start ; meta = s.meta - r.start } *)
let slice_subslice_from_func const =
let open Krml in
let open Ast in
let element_t = TBound 2 in
let slice_t = mk_slice ~const element_t in
let lid = [ "Eurydice" ], "slice_subslice_from" ^ suffix_of_const const in
let binders =
[ Helpers.fresh_binder "s" slice_t; Helpers.fresh_binder "r" (mk_range_from (TInt SizeT)) ]
in
let expr =
(* args *)
let slice = with_type slice_t (EBound 1) in
let range = with_type (mk_range_from (TInt SizeT)) (EBound 0) in
let ptr = with_type (TBuf (element_t, const)) (EField (slice, "ptr")) in
let meta = mk_sizeT (EField (slice, "meta")) in
let start = mk_sizeT (EField (range, "start")) in
let ptr = with_type (TBuf (element_t, const)) (EBufSub (ptr, start)) in
let meta = mk_sizeT (EApp (Helpers.mk_op Sub (TInt SizeT), [ meta; start ])) in
with_type slice_t (EFlat [ Some "ptr", ptr; Some "meta", meta ])
in
DFunction (None, [ Private ], 0, 3, slice_t, lid, binders, expr)
let slice_subslice_from_func_shared = slice_subslice_from_func true
let slice_subslice_from_func_mut = slice_subslice_from_func false
(* Not fully general *)
let static_assert, static_assert_ref =
let name = [ "Eurydice" ], "assert" in
let typ = Krml.Helpers.fold_arrow [ TBool; Krml.Checker.c_string ] TUnit in
( K.DExternal (None, [ Krml.Common.Private; Macro ], 0, 0, name, typ, [ "test"; "msg" ]),
K.(with_type typ (EQualified name)) )
(* Replacements, now applied on-the-fly in AstOfLlbc.
IMPORTANT: such replacements are written in abstract syntax that *already* has cleanups applied,
meaning that some passes like Cleanup1.remove_assignments and un-necessary and will actually error
out. We maintain a list of such functions in Cleanup1, to be kept in sync with this. *)
let unwrap =
let open Krml in
let open Ast in
let t_T = TBound 1 in
let t_E = TBound 0 in
let b = Krml.Helpers.fresh_binder "f0" t_T in
let t_result = mk_result t_T t_E in
let binders = [ Helpers.fresh_binder "self" t_result ] in
(* Ensures this returns always the same term (structurally equal) *)
fun lid ->
DFunction
( None,
[ Private ],
0,
2,
t_T,
lid,
binders,
with_type t_T
(EMatch
( Unchecked,
with_type t_result (EBound 0),
[
( [ b ],
with_type t_result (PCons ("Ok", [ with_type t_T (PBound 0) ])),
with_type t_T (EBound 0) );
( [],
with_type t_result PWild,
with_type t_T (EAbort (Some t_T, Some "unwrap not Ok")) );
] )) )
(* Easier this way rather than implement a macro with an expression-statement.
external core_slice_{@Slice}_swap <1>:
Eurydice_slice
0 ->
size_t ->
size_t ->
()
*)
let slice_swap =
let open Krml in
let open Ast in
let t = TBound 0 in
(* Slice must be mut for elements to be swapped *)
let mk_slice = mk_slice ~const:false in
let binders =
[
Helpers.fresh_binder ~mut:true "s" (mk_slice t);
Helpers.fresh_binder "i" (TInt SizeT);
Helpers.fresh_binder "j" (TInt SizeT);
]
in
(* with slice type *)
let mk_slice = with_type (mk_slice t) in
(* with usize type *)
let index s i =
let slice_index = expr_of_builtin_t slice_index_mut [ t ] in
with_type t (EApp (slice_index, [ s; i ]))
in
let lhs s i =
with_type t (EBufRead (with_type (TBuf (t, false)) (EAddrOf (index s i)), Helpers.zero_usize))
in
fun lid ->
DFunction
( None,
[ Private ],
0,
1,
TUnit,
lid,
binders,
(* let tmp = s[i]; *)
with_type TUnit
(ELet
( Helpers.fresh_binder "tmp" t,
index (mk_slice (EBound 2)) (mk_sizeT (EBound 1)),
with_type TUnit
(ESequence
[
(* s[i] = s[j] *)
with_type TUnit
(EAssign
( lhs (mk_slice (EBound 3)) (mk_sizeT (EBound 2)),
index (mk_slice (EBound 3)) (mk_sizeT (EBound 1)) ));
(* s[j] = tmp *)
with_type TUnit
(EAssign
(lhs (mk_slice (EBound 3)) (mk_sizeT (EBound 1)), with_type t (EBound 0)));
]) )) )
(* Formerly a macro, using GCC expression-statements:
#define alloc_vec__alloc__vec__Vec_T___try_with_capacity(len, t_elt, t_ret) \
({ \
size_t element_sz = sizeof(t_elt); \
Eurydice_vec v = Eurydice_vec_try_with_capacity(len, sizeof(t_elt)); \
t_ret r; \
if (!(len <= SIZE_MAX/element_sz)) \
r = ((t_ret){ .tag = core_result_Err, .val = { .case_Err = { .tag = alloc_collections_CapacityOverflow } } }); \
else if (v.ptr != NULL) { \
r = ((t_ret){ .tag = core_result_Ok, .val = { .case_Ok = v }}); \
} else { \
r = ((t_ret){ .tag = core_result_Err, .val = { .case_Err = { \
.tag = alloc_collections_AllocError, /* CHECK ??? */ \
.layout = { .size = len * sizeof(t_elt), .align = 8 } \
}}}); \
} \
r; \
})
Remember that this is all pre-monomorphization.
*)
let try_with_capacity =
let open Krml in
let open Ast in
let t = TBound 0 in
let t_try_reserve_error = TQualified ([ "alloc"; "collections" ], "TryReserveError") in
(* Result, TryReserveError> *)
let t_ret = TApp (([ "core"; "result" ], "Result"), [ mk_vec t; t_try_reserve_error ]) in
(* TryReserveError { kind = TryReserveErrorKind::Cons args } *)
let mk_try_reserve_error cons args =
with_type t_try_reserve_error
(EFlat
[
( Some "kind",
with_type
(TQualified ([ "alloc"; "collections" ], "TryReserveErrorKind"))
(ECons (cons, args)) );
])
in
let mk_res_error err = with_type t_ret (ECons ("Err", [ err ])) in
let mk_res_ok ok = with_type t_ret (ECons ("Ok", [ ok ])) in
let binders = [ Helpers.fresh_binder "len" (TInt SizeT) ] in
(* with size *)
let ws = with_type (TInt SizeT) in
fun lid ->
DFunction
( None,
[ Private ],
0,
1,
t_ret,
lid,
binders,
with_type t_ret
(EIfThenElse
( (* if vec_overflows(len) then *)
with_type TBool (EApp (expr_of_builtin_t vec_overflows [ t ], [ ws (EBound 0) ])),
(* Result::Error(TryReserveError { kind = TryReserveErrorKind::CapacityOverflow }) *)
mk_res_error (mk_try_reserve_error "CapacityOverflow" []),
(* else let v: vec = vec_alloc len in *)
with_type t_ret
(ELet
( Helpers.fresh_binder "v" (mk_vec t),
with_type (mk_vec t)
(EApp (expr_of_builtin_t vec_alloc [ t ], [ ws (EBound 0) ])),
(* if vec_failed v then *)
with_type t_ret
(EIfThenElse
( with_type TBool
(EApp
( expr_of_builtin_t vec_failed [ t ],
[ with_type (mk_vec t) (EBound 0) ] )),
(* Result::Error(
TryReserveError { kind = TryReserveErrorKind::AllocError { layout: layout(), non_exhaustive: () }}
)
*)
mk_res_error
(mk_try_reserve_error "AllocError"
[
(* "layout", *)
with_type layout_t
(EApp (expr_of_builtin_t layout [ t ], [ Helpers.eunit ]));
(* "non_exhaustive", *)
Helpers.eunit;
]),
(* Result::Ok(v) *)
mk_res_ok (with_type (mk_vec t) (EBound 0)) )) )) )) )
let null_mut =
let open Krml.Ast in
let t = TBound 0 in
fun lid ->
DFunction
( None,
[ Private ],
0,
1,
TBuf (t, false),
lid,
[ Krml.Helpers.fresh_binder "_" TUnit ],
with_type (TBuf (t, false)) EBufNull )
(* -------------------------------------------------------------------------- *)
let builtin_funcs =
[
sizeof;
alignof;
array_repeat;
array_eq;
array_eq_slice_mut;
array_eq_slice_shared;
slice_eq_shared;
slice_eq_mut;
slice_index_shared;
slice_index_mut;
slice_to_array;
slice_to_ref_array;
slice_to_ref_array2;
discriminant;
range_iterator_step_by;
range_step_by_iterator_next;
box_new;
empty_array;
replace;
bitand_pv_u8;
shr_pv_u8;
min_u32;
vec_alloc;
vec_overflows;
vec_failed;
layout;
]
(* Declares the 128-bit operations *)
@ begin
Op128Map.to_seq op_128_cfgs |> List.of_seq |> List.map snd
end
let builtin_defined_funcs =
[
array_to_slice_func_shared;
array_to_slice_func_mut;
array_to_subslice_func_shared;
array_to_subslice_func_mut;
array_to_subslice_to_func_shared;
array_to_subslice_to_func_mut;
array_to_subslice_from_func_shared;
array_to_subslice_from_func_mut;
slice_subslice_func_shared;
slice_subslice_func_mut;
slice_subslice_to_func_shared;
slice_subslice_to_func_mut;
slice_subslice_from_func_shared;
slice_subslice_from_func_mut;
]
let files =
[
Krml.Builtin.lowstar_ignore;
(let externals =
List.map
(fun { name; typ; cg_args; n_type_args; arg_names } ->
let typ = Krml.Helpers.fold_arrow cg_args typ in
let flags = [ Krml.Common.Private ] in
K.DExternal (None, flags, List.length cg_args, n_type_args, name, typ, arg_names))
builtin_funcs
@ builtin_defined_funcs
@ [ nonzero_def; static_assert; c_string_def ]
in
"Eurydice", externals);
]
let is_a_builtin_func_name (name : K.lident) =
(* Potentially make the list of built-in funcs a Map to speed up if necessary. *)
List.exists (fun { name = n; _ } -> n = name) builtin_funcs
================================================
FILE: lib/Bundles.ml
================================================
(* A more modern version of the krml facility that matches on lids (instead of file names), and
relies on a YAML file for configuration (rather than the cryptic syntax). *)
module L = Logging
module K = Krml.Ast
open Krml.Ast
type pattern = Prefix of string list | Exact of string list | Lid of lident [@@deriving show]
type visibility = Api | Internal | Private [@@deriving show]
let string_of_pattern = function
| Exact p -> "[ " ^ String.concat ", " p ^ " ]"
| Prefix p -> "[ " ^ String.concat ", " p ^ ", '*' ]"
| Lid name -> String.concat "_" (fst name @ [ snd name ])
type file = {
name : string;
target : string;
inline_static : bool;
library : bool;
definitions : (pattern * visibility) list;
monomorphizations_using : (pattern * visibility) list;
monomorphizations_of : (pattern * visibility) list;
monomorphizations_exact : (pattern * visibility) list;
}
type config = file list
(** Loading & parsing *)
let load_config (path : string) : Yaml.value =
(* TODO: library not found: Yaml_unix *)
let contents = Krml.Utils.file_get_contents path in
match Yaml.of_string contents with
| Error (`Msg s) -> Krml.Warn.fatal_error "Issue reading configuration file: %s" s
| Ok v -> v
let parsing_error f = Krml.Warn.fatal_error ("Issue parsing configuration file: " ^^ f)
let parse_pattern (v : Yaml.value) : pattern =
match v with
| `A vs ->
let rec parse acc = function
| `String "*" :: [] -> Prefix (List.rev acc)
| `String "*" :: _ -> parsing_error "wildcards only allowed at the end"
| `String s :: tl -> parse (s :: acc) tl
| _ :: _ -> parsing_error "only strings in patterns"
| [] -> Exact (List.rev acc)
in
parse [] vs
| _ -> parsing_error "pattern not a list"
let parse_exact v : pattern =
match parse_pattern v with
| Exact lid -> Lid (Krml.KList.split_at_last lid)
| _ -> parsing_error "monomorphizations_exact does not take wildcards"
let parse_file (v : Yaml.value) : file =
match v with
| `O ls ->
let count = ref 0 in
let lookup k =
try
let r = List.assoc k ls in
incr count;
Some r
with Not_found -> None
in
let lookup_ k ls =
try
let r = List.assoc k ls in
incr count;
Some r
with Not_found -> None
in
let name =
match lookup "name" with
| Some (`String name) -> name
| Some _ -> parsing_error "name not a string"
| None -> parsing_error "missing name"
in
let target =
match lookup "target" with
| Some (`String target) -> target
| Some _ -> parsing_error "target not a string"
| None -> ""
in
let inline_static =
match lookup "inline_static" with
| Some (`Bool inline_static) -> inline_static
| Some _ -> parsing_error "inline_static not a bool"
| None -> false
in
let library =
match lookup "library" with
| Some (`Bool library) -> library
| Some _ -> parsing_error "library not a bool"
| None -> false
in
let map_or f o k =
match lookup_ k o with
| None -> []
| Some (`A l) -> List.map f l
| Some _ -> failwith (k ^ " is not a list")
in
(* TODO: fix copy-pasting *)
let definitions, monomorphizations_of, monomorphizations_using, monomorphizations_exact =
(* Preserve order *)
let rec parse ls =
match ls with
| [] -> [], [], [], []
| ((("api" | "internal" | "private") as k), o) :: ls ->
incr count;
let vis =
match k with
| "api" -> Api
| "internal" -> Internal
| "private" -> Private
| _ -> assert false
in
let parse_pattern_vis p = parse_pattern p, vis in
let parse_exact_vis p = parse_exact p, vis in
let defs, m_of, m_using, m_exact = parse ls in
begin
match o with
| `A pats -> List.map parse_pattern_vis pats @ defs, m_of, m_using, m_exact
| `O o ->
( map_or parse_pattern_vis o "patterns" @ map_or parse_exact_vis o "exact" @ defs,
map_or parse_pattern_vis o "monomorphizations_of" @ m_of,
map_or parse_pattern_vis o "monomorphizations_using" @ m_using,
map_or parse_exact_vis o "monomorphizations_exact" @ m_exact )
| _ -> failwith (k ^ " neither a list nor object")
end
| _ :: ls -> parse ls
in
parse ls
in
let include_ =
match lookup "include_in_h" with
| None -> []
| Some (`A include_) ->
List.map
(function
| `String s -> Krml.Options.HeaderOnly name, s
| _ -> parsing_error "include_in_h must be a string")
include_
| Some _ -> parsing_error "include_in_h must be a list"
in
let include_internal =
match lookup "include_in_internal_h" with
| None -> []
| Some (`A include_) ->
List.map
(function
| `String s -> Krml.Options.InternalOnly name, s
| _ -> parsing_error "include_in_internal_h must be a string")
include_
| Some _ -> parsing_error "include_in_internal_h must be a list"
in
let c_include_ =
match lookup "include_in_c" with
| None -> []
| Some (`A include_) ->
List.map
(function
| `String s -> Krml.Options.COnly name, s
| _ -> parsing_error "include_in_c must be a string")
include_
| Some _ -> parsing_error "include_in_c must be a list"
in
if !count < List.length ls then
parsing_error "extraneous fields in file";
Krml.Options.(
add_early_include := include_ @ c_include_ @ include_internal @ !add_early_include);
{
name;
definitions;
inline_static;
library;
monomorphizations_using;
monomorphizations_of;
monomorphizations_exact;
target;
}
| _ -> parsing_error "file must be an object"
let parse_config (v : Yaml.value) : config =
match v with
| `O entries ->
(match List.assoc_opt "naming" entries with
| None -> ()
| Some naming ->
let skip_prefix =
match naming with
| `O [ ("skip_prefix", `A prefixes) ] -> prefixes
| `O [ ("skip_prefix", _) ] -> parsing_error "skip_prefix must be a list"
| _ -> parsing_error "naming must be an object with the following keys: skip_prefix"
in
let skip_prefix =
List.map
(function
| `A m ->
List.map
(function
| `String s -> s
| _ -> parsing_error "skip_prefix component not a list of strings")
m
| _ -> parsing_error "entries under skip prefix must be a list of strings")
skip_prefix
in
let skip_prefix = List.map (fun p -> Krml.Bundle.Module p) skip_prefix in
Krml.Options.(no_prefix := !no_prefix @ skip_prefix));
begin
match List.assoc_opt "files" entries with
| Some (`A files) -> List.map parse_file files
| _ -> parsing_error "files is not a sequence"
end
| _ -> parsing_error "YAML file must be an object with key files"
(** Constructing bundles *)
let starts_with l prefix =
List.length prefix <= List.length l && fst (Krml.KList.split (List.length prefix) l) = prefix
(* `lid` matches pattern `p` *)
let matches lid p =
match p with
| Exact m -> m = fst lid
| Prefix prefix -> starts_with (fst lid) prefix
| Lid lid' -> lid = lid'
let find_map desc f l =
List.find_map
(fun (arg, ret) ->
if f arg then
Some (arg, ret, desc)
else
None)
l
let mark_internal =
let add_if name flags =
let is_internal = List.mem Krml.Common.Internal flags in
if (not is_internal) && not (Krml.Inlining.always_live name) then
Krml.Common.Internal :: List.filter (( <> ) Krml.Common.Private) flags
else
List.filter (( <> ) Krml.Common.Private) flags
in
function
| DFunction (cc, flags, n_cgs, n, typ, name, binders, body) ->
DFunction (cc, add_if name flags, n_cgs, n, typ, name, binders, body)
| DGlobal (flags, name, n, typ, body) -> DGlobal (add_if name flags, name, n, typ, body)
| DType (lid, flags, n_cgs, n, def) -> DType (lid, add_if lid flags, n_cgs, n, def)
| DExternal (cc, flags, n_cg, n, lid, t, pp) ->
DExternal (cc, add_if lid flags, n_cg, n, lid, t, pp)
let adjust vis decl =
match vis with
| Api -> decl
| Private -> Krml.Bundles.mark_private decl
| Internal -> mark_internal decl
let record_inline_static lid = Krml.Options.(static_header := Lid lid :: !static_header)
let bundle (files : Krml.Ast.file list) (c : config) : files =
let bundled = Hashtbl.create 137 in
let bundle name decl =
if Hashtbl.mem bundled name then
Hashtbl.replace bundled name (decl :: Hashtbl.find bundled name)
else
Hashtbl.add bundled name [ decl ]
in
let record_library lid = Krml.Options.(library := Lid lid :: !library) in
let files =
List.map
(fun ((filename : string), (decls : Krml.Ast.decl list)) ->
( filename,
List.filter_map
(fun decl ->
let lid = lid_of_decl decl in
let rec find config =
match config with
| [] ->
Krml.(KPrint.bprintf "%a doesn't go anywhere\n" PrintAst.Ops.plid lid);
false
| { name; definitions; inline_static; library; _ } :: config -> (
(* Krml.KPrint.bprintf "for %s, definitions are :\n" name; *)
(* List.iter (fun (p, vis) -> *)
(* Krml.KPrint.bprintf "%s: %s\n" (show_visibility vis) (show_pattern p) *)
(* ) definitions; *)
match
List.find_map
(fun (pat, vis) ->
if matches lid pat then
Some vis
else
None)
definitions
with
| None -> find config
| Some vis ->
(* Krml.(KPrint.bprintf "%a goes into %s at vis %s\n" PrintAst.Ops.plid lid name (show_visibility vis)); *)
(* if List.length vis_ > 1 then *)
(* Krml.(KPrint.bprintf "vis_ was: %s\n" (String.concat ", " (List.map show_visibility vis_))); *)
let decl = adjust vis decl in
bundle name decl;
if inline_static then
record_inline_static lid;
if library then
record_library lid;
true)
in
if find c then
None
else
Some decl)
decls ))
files
in
let files =
List.filter
(fun (filename, decls) ->
(* Collision between the original crate name (e.g. libcrux_kyber) and the destination bundle
(e.g. libcrux_kyber). *)
if Hashtbl.mem bundled filename then begin
List.iter (bundle filename) decls;
false
end
else
true)
files
in
Hashtbl.fold
(fun filename decls acc -> (filename, List.rev decls) :: acc)
bundled
(List.filter (fun (_, decls) -> decls <> []) files)
let libraries (files : Krml.Ast.file list) : files =
List.map
(fun (f, decls) ->
( f,
List.filter_map
(fun d ->
let lid = Krml.Ast.lid_of_decl d in
if List.exists (fun p -> Krml.(Bundle.pattern_matches_lid p lid)) !Krml.Options.library
then begin
Logging.log "Libraries" "%a becomes abstract\n" Krml.PrintAst.Ops.plid lid;
match d with
| DType (_, _, _, _, Abbrev _) as t -> Some t
| DType _ -> None
| d -> Krml.Builtin.make_abstract_function_or_global d
end
else
Some d)
decls ))
files
let topological_sort decls =
let module T = struct
type color = White | Gray | Black
end in
let open T in
let graph = Hashtbl.create 41 in
let is_forward = function
| DType (_, _, _, _, Forward _) -> `Forward
| _ -> `Regular
in
List.iter
(fun decl ->
let deps =
begin
object (self)
inherit [_] reduce as super
method zero = []
method plus = ( @ )
method! visit_EQualified (under_ref, _) lid = [ lid, under_ref ]
method! visit_TQualified under_ref lid = [ lid, under_ref ]
method! visit_TApp under_ref lid ts =
[ lid, under_ref ] @ List.concat_map (self#visit_typ under_ref) ts
method! visit_TBuf _ t const = super#visit_TBuf true t const
end
end
#visit_decl
false decl
in
Hashtbl.add graph (lid_of_decl decl, is_forward decl) (ref White, deps, decl))
decls;
if L.has_logging "dfs" then
Hashtbl.iter
(fun (lid, forward) (_, deps, _) ->
let open Krml in
let open PrintAst.Ops in
KPrint.bprintf "%a(%s) depends on: %s\n" plid lid
(match forward with
| `Forward -> "forward"
| `Regular -> "regular")
(String.concat " ++ "
(List.map (fun (lid, b) -> KPrint.bsprintf "%a(%b)" plid lid b) deps)))
graph;
let stack = ref [] in
let rec dfs (lid, under_ref) =
let has_forward_decl = Hashtbl.mem graph (lid, `Forward) in
if Hashtbl.mem graph (lid, `Regular) || has_forward_decl then
let key =
if has_forward_decl && under_ref then
lid, `Forward
else
lid, `Regular
in
let r, deps, decl = Hashtbl.find graph key in
match !r with
| Black -> ()
| Gray -> ()
| White ->
r := Gray;
List.iter dfs deps;
r := Black;
(* Krml.(PrintAst.Ops.(KPrint.bprintf "%a %b\n" plid lid under_ref)); *)
stack := decl :: !stack
in
List.iter (fun decl -> dfs (lid_of_decl decl, false)) decls;
List.rev !stack
module LidMap = Krml.Idents.LidMap
(* Because the krml monomorphization procedure is not optimal, it is sometimes
the case the our topological sort places a forward declaration *after* the
corresponding struct. Filter those out! *)
let filter_forward files =
let seen = Hashtbl.create 41 in
List.map
(fun (file, decls) ->
( file,
List.filter_map
(fun decl ->
match decl with
| DType (lid, _, _, _, Forward _) when Hashtbl.mem seen lid -> None
| _ ->
Hashtbl.add seen (lid_of_decl decl) ();
Some decl)
decls ))
files
(* Second phase of bundling, post-monomorphization. This is Eurydice-specific,
as we oftentimes need to move definitions that have been /specialized/ using
e.g. a platform-specific trait into their own file.
Note that there may be multiple definitions per `lid`, because of forward structs. *)
let reassign_monomorphizations (files : Krml.Ast.file list) (config : config) =
let open Krml.Ast in
let open Krml.PrintAst.Ops in
(* Pure sanity check *)
let count_decls files =
List.fold_left
(fun acc (_, decls) ->
let add_incr lid map =
if LidMap.mem lid map then
LidMap.add lid (LidMap.find lid map + 1) map
else
LidMap.add lid 1 map
in
List.fold_left (fun acc decl -> add_incr (lid_of_decl decl) acc) acc decls)
LidMap.empty files
in
let c0 = count_decls files in
let target_of_lid = Hashtbl.create 41 in
let ( ||| ) o1 o2 =
match o1 with
| Some _ -> o1
| None -> o2
in
let reverse_type_map =
(* Maps t____u (an lid) to t (a type application) *)
let map = Hashtbl.create 41 in
Hashtbl.iter
(fun node (_, monomorphized_lid) ->
assert (snd3 node <> [] || thd3 node <> []);
Hashtbl.add map monomorphized_lid (fold_tapp node))
Krml.MonomorphizationState.state;
map
in
let uses monomorphizations_using t =
begin
object (self)
inherit [_] reduce as super
method private visit_through_map lid =
Option.bind (Hashtbl.find_opt reverse_type_map lid) (self#visit_typ ())
method zero = None
method plus o1 o2 =
if o1 = None then
o2
else
o1
method! visit_TQualified _ lid' =
find_map "monomorphizations_using" (matches lid') monomorphizations_using
||| self#visit_through_map lid'
method! visit_TApp _ lid' ts =
find_map "monomorphizations_using" (matches lid') monomorphizations_using
||| self#visit_through_map lid' ||| super#visit_TApp () lid' ts
end
end
#visit_typ
() t
in
(* Review the function monomorphization state.
THOUGHTS: maybe this should just all be grouped as a single field? Do we really care about
catching `t` but not `u`? (i.e., distinguish monomorphizations *of* from
monomorphizations using?
Semantics of `monomorphizations_using`:
if `lid`, below, is the result of a (function) monomorphization that
*uses* (in its arguments, `cgs`, below) an `lid'` that matches a
`monomorphizations_using` clause of file `name`, then `lid` moves to
`name`.
Semantics of `monomorphizations_of`: unlike above, this matches a
generic lid (e.g., we want all the monomorphized instances of `Result` to
go into a single file)
Semantics of `monomorphizations_exact`: self-explanatory
*)
Hashtbl.iter
(fun (generic_lid, cgs, ts) monomorphized_lid ->
match
List.find_map
(fun {
name;
inline_static;
monomorphizations_using;
monomorphizations_of;
monomorphizations_exact;
_;
} ->
(* Monomorphization resulting in exactly this name *)
find_map "monomorphizations_exact" (matches monomorphized_lid) monomorphizations_exact
|||
(* Monomorphization using given trait name, amongst the arguments *)
List.find_map
(fun e ->
match e.node with
| EQualified lid' ->
find_map "monomorphizations_using" (matches lid') monomorphizations_using
| _ -> None)
cgs
|||
(* Monomorphization using given type name *)
List.find_map (uses monomorphizations_using) ts
|||
(* Monomorphization of a given polymorphic name *)
find_map "monomorphizations_of" (matches generic_lid) monomorphizations_of
|> Option.map (fun vis -> name, inline_static, vis))
config
with
| Some name -> Hashtbl.add target_of_lid monomorphized_lid name
| None -> ())
Krml.MonomorphizationState.generated_lids;
(* Review the type monomorphization state. *)
Hashtbl.iter
(fun (generic_lid, ts, _) (_, monomorphized_lid) ->
(* Krml.KPrint.bprintf "generic=%a, monomorphized=%a\n" plid generic_lid plid monomorphized_lid; *)
match
List.find_map
(fun {
name;
inline_static;
monomorphizations_of;
monomorphizations_using;
monomorphizations_exact;
_;
} ->
find_map "monomorphizations_exact" (matches monomorphized_lid) monomorphizations_exact
||| List.find_map (uses monomorphizations_using) ts
||| find_map "monomorphizations_of" (matches generic_lid) monomorphizations_of
|> Option.map (fun vis -> name, inline_static, vis))
config
with
| Some name -> Hashtbl.add target_of_lid monomorphized_lid name
| None -> ())
Krml.MonomorphizationState.state;
(* Debug *)
Hashtbl.iter
(fun lid (target, _inline_static, (pat, vis, desc)) ->
L.log "Reassign"
"declaration %a goes into file %s (at visibility: %s) because it matched %s in a %s section"
plid lid target (show_visibility vis) (string_of_pattern pat) desc)
target_of_lid;
(* Filter the files, plucking out those that move and registering them under
the right file name in `reassigned`. We maintain the invariant of one entry
per key in the table. *)
let reassigned = Hashtbl.create 41 in
let files =
List.map
(fun (f, decls) ->
( f,
List.filter
(fun decl ->
let lid = lid_of_decl decl in
match Hashtbl.find_all target_of_lid lid with
| exception Not_found -> true
| [] -> true
| entries ->
List.iter
(fun (target, inline_static, (_, vis, _)) ->
let decl = adjust vis decl in
if inline_static then
record_inline_static lid;
if Hashtbl.mem reassigned target then
Hashtbl.replace reassigned target (decl :: Hashtbl.find reassigned target)
else
Hashtbl.add reassigned target [ decl ])
(List.rev entries);
false)
decls ))
files
in
(* Extend each file with the definitions that are moving into it. *)
let files =
List.map
(fun (f, decls) ->
let reassigned =
if Hashtbl.mem reassigned f then (
let r = Hashtbl.find reassigned f in
Hashtbl.remove reassigned f;
r)
else
[]
in
f, decls @ reassigned)
files
in
(* Deal with files that did not exist previously. *)
let files = files @ Hashtbl.fold (fun f reassigned acc -> (f, reassigned) :: acc) reassigned [] in
(* A quick topological sort to make sure type declarations come *before*
functions that use them. Note that this is incompatible with forward structs. *)
let files = List.map (fun (f, decls) -> f, topological_sort decls) files in
let c1 = count_decls files in
ignore
(LidMap.merge
(fun lid v1 v2 ->
match v1, v2 with
| None, None -> failwith "impossible"
| Some v1, None -> Krml.Warn.fatal_error "lost %d declaration for %a\n" v1 plid lid
| None, Some v2 -> Krml.Warn.fatal_error "gained %d declaration for %a\n" v2 plid lid
| Some v1, Some v2 ->
if v1 != v2 then
Krml.Warn.fatal_error "mismatch on %a: %d != %d\n" plid lid v1 v2
else
None)
c0 c1);
let files = filter_forward files in
files
================================================
FILE: lib/Cleanup1.ml
================================================
open Krml.Ast
open Krml.DeBruijn
module H = Krml.Helpers
module AtomMap = Map.Make (Krml.Atom)
module AtomSet = Set.Make (Krml.Atom)
let set_of_map_keys m = AtomSet.of_list (List.map fst (AtomMap.bindings m))
let count_atoms =
object
inherit [_] reduce
method private zero = AtomSet.empty
method private plus = AtomSet.union
method! visit_EOpen _ _ a = AtomSet.singleton a
end
type remove_env = (string * typ * node_meta list * meta list) AtomMap.t
let pmeta buf ({ meta; _ } : 'a with_type) =
List.iter
(function
| CommentBefore s | CommentAfter s ->
Buffer.add_string buf s;
Buffer.add_char buf '\n')
meta
let mk typ meta node = { node; typ; meta }
let is_sequence = Krml.Simplify.is_sequence
let already_clean = function
| [ "core"; "slice"; _ ], "swap" -> true
| [ "alloc"; "vec"; _ ], "try_with_capacity" -> true
| _ -> false
let remove_assignments =
object (self)
inherit [_] map
method private peel_lets (to_close : remove_env) e =
match e.node with
| ELet (b, e1, e2) ->
(if not (e1.node = EAny || e1.node = EUnit) then
Krml.(Warn.fatal_error "Initializer of let-binding is %a" PrintAst.Ops.pexpr e1));
(* Krml.(KPrint.bprintf "peeling %s\n" b.node.name); *)
let b, e2 = open_binder b e2 in
(* Krml.KPrint.bprintf "peel: let-binding meta %a\n" pmeta b; *)
let to_close =
AtomMap.add b.node.atom (b.node.name, b.typ, b.meta, b.node.meta) to_close
in
self#peel_lets to_close e2
| _ ->
let e = Krml.Simplify.sequence_to_let#visit_expr_w () e in
(* Krml.(KPrint.bprintf "after peeling:\n%a\n\n" PrintAst.Ops.ppexpr e); *)
self#visit_expr_w to_close e
method! visit_DFunction (to_close : remove_env) cc flags n_cgs n t name bs e =
(* Krml.(KPrint.bprintf "visiting %a\n" PrintAst.Ops.plid name); *)
assert (AtomMap.is_empty to_close);
DFunction
( cc,
flags,
n_cgs,
n,
t,
name,
bs,
if already_clean name then
e
else
self#peel_lets to_close e )
method! visit_DGlobal (to_close : remove_env) flags n t name e =
assert (AtomMap.is_empty to_close);
DGlobal (flags, n, t, name, self#peel_lets to_close e)
method! visit_ELet ((not_yet_closed : remove_env), t) b e1 e2 =
(* If [not_yet_closed] represents the set of bindings that have yet to be
closed (i.e. for which we have yet to insert a let-binding, as close as
possible to the first use-site), and [candidates] represents the atoms
that we know for sure must be closed right now, then [close_now_over]
inserts suitable let-bindings for the candidates that have not yet been
closed, then calls the continuation with the remaining subset of
not_yet_closed. *)
let close_now_over (not_yet_closed : remove_env) candidates mk_node =
let to_close_now = AtomSet.inter candidates (set_of_map_keys not_yet_closed) in
let bs = List.of_seq (AtomSet.to_seq to_close_now) in
let bs =
List.map
(fun atom ->
let name, typ, meta, binder_meta = AtomMap.find atom not_yet_closed in
( {
node = { atom; name; mut = true; mark = ref Krml.Mark.default; meta = binder_meta };
typ;
meta;
},
if typ = TUnit then
Krml.Helpers.eunit
else
Krml.Helpers.any ))
bs
in
(* For the subexpressions, we now need to insert declarations for those variables that we're
not handling now. *)
let not_yet_closed =
AtomMap.filter (fun a _ -> not (AtomSet.mem a to_close_now)) not_yet_closed
in
let node = mk_node not_yet_closed in
(* XXX why is the with_type necessary here?? *)
(Krml.Helpers.nest bs t (with_type t node)).node
in
let count e = count_atoms#visit_expr_w () e in
let ( ++ ) = AtomSet.union in
(* Called when hitting a node in terminal position: either fall back into
the general case if it's a let-node; special treatment if it's
control-flow (match, if, while); otherwise, just close everything now and
move on (wildcard case). *)
let rec recurse_or_close (not_yet_closed : remove_env) e0 =
let t = e0.typ in
match e0.node with
| ELet _ ->
(* let node: restart logic and jump back to match below *)
self#visit_expr_w not_yet_closed e0
| EIfThenElse (e, e', e'') ->
mk t e0.meta
@@ close_now_over not_yet_closed
((* We must now bind: *)
count e
++
(* whichever variables were in the condition *)
AtomSet.empty)
(* unlike below, we are in terminal position, so we do not need to
close immediately variables that appear in both branches -- we can simply declare them
twice in each branch! is this a better code-gen choice? yes, absolutely -- owing to
the structure of MIR, NOT doing this generates awful code *)
(fun not_yet_closed ->
EIfThenElse
( self#visit_expr_w not_yet_closed e,
recurse_or_close not_yet_closed e',
recurse_or_close not_yet_closed e'' ))
| EWhile (e, e') ->
mk t e0.meta
@@ close_now_over not_yet_closed (count e) (fun not_yet_closed ->
EWhile (self#visit_expr_w not_yet_closed e, recurse_or_close not_yet_closed e'))
| ESwitch (e, branches) ->
mk t e0.meta
@@ close_now_over not_yet_closed
((* We must now bind: *)
count e
++
(* i.e., whichever variables were in the condition *)
AtomSet.empty)
(* see above *)
(fun not_yet_closed ->
ESwitch
( self#visit_expr_w not_yet_closed e,
List.map (fun (p, e) -> p, recurse_or_close not_yet_closed e) branches ))
| EMatch (c, e, branches) ->
mk t e0.meta
@@ close_now_over not_yet_closed
((* We must now bind: *)
count e
++
(* i.e., whichever variables were in the condition *)
AtomSet.empty)
(* see above *)
(fun not_yet_closed ->
EMatch
( c,
self#visit_expr_w not_yet_closed e,
List.map
(fun (bs, p, e) -> bs, p, recurse_or_close not_yet_closed e)
branches ))
| _ ->
(* There are opportunities for finesse here, for instance, if we reach
an assignment in terminal position, *and* the variable has yet to
be closed, it means that the assignment is useless since no one
else will be using the variable after that. *)
mk t e0.meta
@@ close_now_over not_yet_closed (count e0) (fun not_yet_closed ->
(* not_yet_closed should be empty at this stage *)
(self#visit_expr_w not_yet_closed e0).node)
in
match e1.node with
| EAssign ({ node = EOpen (_, atom); _ }, e_rhs) when AtomMap.mem atom not_yet_closed ->
close_now_over not_yet_closed (count e_rhs) (fun not_yet_closed ->
(* Combined "close now" (above) + let-binding insertion in lieu of the assignment *)
assert (is_sequence b.node.meta);
let e2 = snd (open_binder b e2) in
let name, typ, meta, binder_meta = AtomMap.find atom not_yet_closed in
let b =
{
node =
{ atom; name; mut = true; mark = ref Krml.Mark.default; meta = binder_meta };
typ;
meta = meta @ e1.meta;
}
in
let not_yet_closed = AtomMap.remove atom not_yet_closed in
(* Krml.(KPrint.bprintf "rebuilt: %a\n" PrintAst.Ops.pexpr (with_type TUnit (ELet (b, e_rhs, e2)))); *)
let e2 = recurse_or_close not_yet_closed (close_binder b e2) in
ELet (b, e_rhs, e2))
| EIfThenElse (e, e', e'') ->
assert (is_sequence b.node.meta);
close_now_over not_yet_closed
((* We must now bind: *)
count e
++
(* whichever variables were in the condition *)
AtomSet.inter (count e') (count e'')
++
(* variables that appear in both branches *)
AtomSet.inter (count e' ++ count e'') (count e2))
(* variables in either branch *and* used later *)
(fun not_yet_closed ->
ELet
( b,
mk e1.typ e1.meta
(EIfThenElse
( self#visit_expr_w not_yet_closed e,
recurse_or_close not_yet_closed e',
recurse_or_close not_yet_closed e'' )),
recurse_or_close not_yet_closed e2 ))
| EWhile (e, e') ->
assert (is_sequence b.node.meta);
close_now_over not_yet_closed
(* We must be here variables that are declared in the condition, and variables that
appear both in the loop body and its continuation. *)
(count e ++ AtomSet.inter (count e') (count e2))
(fun not_yet_closed ->
ELet
( b,
mk e1.typ e1.meta
(EWhile (self#visit_expr_w not_yet_closed e, recurse_or_close not_yet_closed e')),
recurse_or_close not_yet_closed e2 ))
| ESwitch (e, branches) ->
assert (is_sequence b.node.meta);
close_now_over not_yet_closed
((* We must now bind: *)
count e
++
(* i.e., whichever variables were in the condition *)
Krml.KList.reduce AtomSet.inter (List.map (fun (_p, e) -> count e) branches)
++
(* i.e., variables that appear in all branches -- note that
switches don't bind variables in their branches so it's simpler
than the match below*)
AtomSet.inter
(Krml.KList.reduce ( ++ ) (List.map (fun (_, e) -> count e) branches))
(count e2))
(* i.e., variables in either one of the branches *and* used later *)
(fun not_yet_closed ->
ELet
( b,
mk e1.typ e1.meta
(ESwitch
( self#visit_expr_w not_yet_closed e,
List.map (fun (p, e) -> p, recurse_or_close not_yet_closed e) branches )),
recurse_or_close not_yet_closed e2 ))
| EMatch (c, e, branches) ->
assert (is_sequence b.node.meta);
close_now_over not_yet_closed
((* We must now bind: *)
count e
++
(* i.e., whichever variables were in the condition *)
Krml.KList.reduce AtomSet.inter (List.map (fun (_bs, _p, e) -> count e) branches)
++
(* i.e., variables that appear in all branches -- note that we
don't open _bs meaning that we don't collect bound variables in this branch *)
AtomSet.inter
(Krml.KList.reduce ( ++ ) (List.map (fun (_, _, e) -> count e) branches))
(count e2))
(* i.e., variables in either one of the branches *and* used later *)
(fun not_yet_closed ->
ELet
( b,
mk e1.typ e1.meta
(EMatch
( c,
self#visit_expr_w not_yet_closed e,
List.map
(fun (bs, p, e) -> bs, p, recurse_or_close not_yet_closed e)
branches )),
recurse_or_close not_yet_closed e2 ))
| _ ->
(* The open variables in e1 for which we have not yet inserted a declaration need to be closed now *)
close_now_over not_yet_closed (count e1) (fun not_yet_closed ->
ELet (b, self#visit_expr_w not_yet_closed e1, recurse_or_close not_yet_closed e2))
end
let remove_terminal_returns =
object (self)
inherit [_] map
method! visit_DFunction env cc flags n_cgs n t name bs e =
DFunction
( cc,
flags,
n_cgs,
n,
t,
name,
bs,
if already_clean name then
e
else
self#visit_expr_w env e )
method! visit_ELet (terminal, _) b e1 e2 =
(* let _ = x := e in
return x ~~~> return e
*)
match e1.node, e2.node with
| EAssign ({ node = EBound i; _ }, e1), EReturn { node = EBound j; _ } when j = i + 1 ->
(* This early optimization is important to avoid superfluous variable
declarations for the return value of the function -- these
interfere with pattern-matches such as resugar_loops. See
test/for.rs *)
self#visit_EReturn (terminal, e2.typ) e1
| _ -> ELet (b, self#visit_expr_w false e1, self#visit_expr_w terminal e2)
method! visit_EWhile _ e1 e2 = EWhile (self#visit_expr_w false e1, self#visit_expr_w false e2)
method! visit_EFor _ b e1 e2 e3 e4 =
EFor
( b,
self#visit_expr_w false e1,
self#visit_expr_w false e2,
self#visit_expr_w false e3,
self#visit_expr_w false e4 )
method! visit_EReturn (terminal, _) e =
if terminal then
(self#visit_expr_w terminal e).node
else
EReturn (self#visit_expr_w terminal e)
method! visit_ESequence (terminal, _) es =
let es, e = Krml.KList.split_at_last es in
ESequence (List.map (self#visit_expr_w false) es @ [ self#visit_expr_w terminal e ])
method! visit_EIfThenElse (terminal, _) e1 e2 e3 =
EIfThenElse
(self#visit_expr_w false e1, self#visit_expr_w terminal e2, self#visit_expr_w terminal e3)
method! visit_EMatch (terminal, _) f e branches =
EMatch
( f,
self#visit_expr_w false e,
List.map (fun (b, p, e) -> b, p, self#visit_expr_w terminal e) branches )
end
let remove_terminal_continues =
object (self)
inherit [_] map
method! visit_DFunction env cc flags n_cgs n t name bs e =
DFunction
( cc,
flags,
n_cgs,
n,
t,
name,
bs,
if already_clean name then
e
else
self#visit_expr_w env e )
method! visit_ELet (terminal, _) b e1 e2 =
ELet (b, self#visit_expr_w false e1, self#visit_expr_w terminal e2)
method! visit_EWhile _ e1 e2 = EWhile (self#visit_expr_w false e1, self#visit_expr_w true e2)
method! visit_EFor _ b e1 e2 e3 e4 =
EFor
( b,
self#visit_expr_w false e1,
self#visit_expr_w false e2,
self#visit_expr_w false e3,
self#visit_expr_w true e4 )
method! visit_EContinue (terminal, t) =
if terminal then begin
assert (t = TUnit);
EUnit
end
else
EContinue
method! visit_ESequence (terminal, _) es =
let es, e = Krml.KList.split_at_last es in
ESequence (List.map (self#visit_expr_w false) es @ [ self#visit_expr_w terminal e ])
method! visit_EIfThenElse (terminal, _) e1 e2 e3 =
EIfThenElse
(self#visit_expr_w false e1, self#visit_expr_w terminal e2, self#visit_expr_w terminal e3)
method! visit_EMatch (terminal, _) f e branches =
EMatch
( f,
self#visit_expr_w false e,
List.map (fun (b, p, e) -> b, p, self#visit_expr_w terminal e) branches )
end
let unsigned_overflow_is_ok_in_c =
object
inherit [_] map as super
method! visit_EApp env e es =
let is_u = function
| "u8" | "u16" | "u32" | "u64" | "usize" -> true
| _ -> false
in
let as_w = function
| "u8" -> K.UInt8
| "u16" -> UInt16
| "u32" -> UInt32
| "u64" -> UInt64
| "usize" -> SizeT
| _ -> failwith "not an unsigned crate name"
in
let as_t t = TInt (as_w t) in
match e.node with
| EQualified ([ "core"; "num"; t; _ ], "wrapping_add") when is_u t ->
EApp (Krml.Helpers.mk_op Add (as_t t), es)
| EQualified ([ "core"; "num"; t; _ ], "wrapping_sub") when is_u t ->
EApp (Krml.Helpers.mk_op Sub (as_t t), es)
| EQualified ([ "core"; "num"; t; _ ], "wrapping_mul") when is_u t ->
EApp (Krml.Helpers.mk_op Mult (as_t t), es)
| _ -> super#visit_EApp env e es
end
(* PPrint.(Krml.Print.(print (Krml.PrintAst.print_files files ^^ hardline))); *)
let remove_slice_eq =
object (self)
inherit [_] map as super
method private do_it ~const eq t u s1 s2 =
assert (t = u);
let slice_eq =
if const then
Builtin.slice_eq_shared
else
Builtin.slice_eq_mut
in
match flatten_tapp t with
| lid, [ t ], [] when lid = Builtin.derefed_slice ->
let rec is_flat = function
| TArray (t, _) -> is_flat t
| TInt _ | TBool | TUnit -> true
| _ -> false
in
if not (is_flat t) then
failwith "TODO: slice eq at non-flat types";
with_type TBool (EApp (Builtin.expr_of_builtin_t slice_eq [ t ], [ s1; s2 ]))
| _ ->
let deref e = with_type (H.assert_tbuf e.typ) (EBufRead (e, H.zero_usize)) in
with_type TBool (EApp (List.hd eq, [ deref s1; deref s2 ]))
method! visit_expr _ e =
match e with
| [%cremepat {| core::cmp::impls::?impl::eq(#?eq..)(?s1, ?s2) |}] -> begin
match impl with
| "{core::cmp::PartialEq<&0 mut (B)> for &1 mut (A)}" ->
self#do_it ~const:false eq t u s1 s2
| "{core::cmp::PartialEq<&0 (B)> for &1 (A)}" -> self#do_it ~const:true eq t u s1 s2
| _ -> failwith "unknown eq impl in core::cmp::impls"
end
| _ -> super#visit_expr ((), e.typ) e
end
let remove_units =
object (self)
inherit [_] map as super
(* Every local variable at type unit is suitably initialized *)
method! visit_ELet env b e1 e2 =
if b.typ = TUnit && e1.node = EAny then
ELet (b, Krml.Helpers.eunit, self#visit_expr_w () e2)
else
super#visit_ELet env b e1 e2
(* Assigning into a local variable of type unit is meaningless and the rhs can be used instead
-- no uninitialized variables issues, because of ELet above. *)
method! visit_EAssign env e1 e2 =
match e1.node with
| EBound _ when e1.typ = TUnit -> (self#visit_expr_w () e2).node
| _ -> super#visit_EAssign env e1 e2
(* Returning a local variable of type unit is equivalent to returning a unit *)
method! visit_EReturn env e =
match e.node with
| EBound _ when e.typ = TUnit -> EReturn Krml.Helpers.eunit
| _ -> super#visit_EReturn env e
method! visit_ESequence _env es =
let es = List.filter (fun x -> x.node <> EUnit) (List.map (self#visit_expr_w ()) es) in
match es with
| [] -> EUnit
| [ e ] -> e.node
| _ -> ESequence es
end
let cleanup files =
let files = remove_units#visit_files () files in
let files = remove_assignments#visit_files AtomMap.empty files in
let files = unsigned_overflow_is_ok_in_c#visit_files () files in
let files = remove_terminal_returns#visit_files true files in
let files = Krml.Simplify.optimize_lets files in
(* Krml.(PPrint.(Print.(print (PrintAst.print_files files ^^ hardline)))); *)
let files = remove_terminal_continues#visit_files false files in
let files = Krml.Simplify.let_to_sequence#visit_files () files in
let files = remove_slice_eq#visit_files () files in
files
================================================
FILE: lib/Cleanup2.ml
================================================
open Krml.Ast
open Krml.DeBruijn
module H = Krml.Helpers
module L = Logging
open Krml.PrintAst.Ops
(* Target cleanups invoked from bin/main.ml *)
(* A note on the various cleanup phases for arrays to preserve the semantics of Rust. Assume
`struct S { y: [u32; 4] }`.
... pass by ref
1. remove_array_repeats: [e; N] becomes bufcreate e N, or bufcreateL, depending on some
heuristics -- see comments in this phase
2. remove_literals: let x = S { y: foo } --> let x; x.y := foo; x
where the assignment has an array type -- this is either because foo would decay in C and as
such cannot appear in the initializer; or because of foo if of a syntactic form that does not
suit itself to becoming an initializer (e.g. is an if-then-else).
3. remove_implicit_array_copies: handles x := e1 at array types, including nested array cases
... hoist
Phase 2. performs a limited form of hoisting, There is an invariant that hoist cannot be more
aggressive than 2., otherwise, there will be array copy-assignments that won't be compiled.
*)
(* In the initial value of a variable, is this a suitable expression to initialize something that
has an array type (or a struct that may contain arrays)? *)
let rec is_suitable_array_initializer =
let rec subarrays_only_literals e =
(* Underneath an initializer list *)
match e.node, e.typ with
| _, TArray _ ->
(* In the case of nested arrays *)
begin
match e.node with
| EBufCreateL (_, es) ->
(* We only allow sub-initializer lists *)
List.for_all subarrays_only_literals es
| _ ->
(* Anything else (e.g. variable) is not copy-assignment in C *)
false
end
| EFlat es, _ -> List.for_all subarrays_only_literals (List.map snd es)
| _ ->
(* If this is not a nested array, then anything goes *)
true
in
function
| EAny | EBufCreate _ -> true
| EBufCreateL (_, es) -> List.for_all subarrays_only_literals es
| EFlat es -> List.for_all subarrays_only_literals (List.map snd es)
| _ -> false
(* A general phase that removes assignments at array types. Note that all array repeat expressions
are desugared before this. We try to reduce all cases to the assignment case (e1 := e2). *)
let remove_implicit_array_copies =
object (self)
inherit [_] map as super
(* Desugar `lhs := rhs in e2`, because `rhs` has an array type and `not (is_suitable_initializer rhs)`. *)
method private remove_assign n lhs rhs e2 =
(* Krml.KPrint.bprintf "remove_assign %a := %a\n" pexpr lhs pexpr rhs; *)
let is_array = function
| TArray _ -> true
| _ -> false
in
(* What are we trying to assign? *)
match rhs.node with
| EBufCreateL (Stack, es) ->
if List.for_all (( = ) (List.hd es)) es && not (is_array (List.hd es).typ) then
(* We assign a list of elements that are all identical -- optimize *)
let lift = Krml.DeBruijn.lift 1 in
ELet
( H.sequence_binding (),
H.with_unit (EBufFill (lhs, List.hd es, Krml.Helpers.mk_uint32 (List.length es))),
lift e2 )
else begin
(* lhs := bufcreatel e1, e2, ... ~~> lhs[0] := e1, lhs[1] := e2, ...
we possibly recurse if the type of elements is an array *)
assert (List.length es = int_of_string (snd n));
let lift = Krml.DeBruijn.lift in
let rec nest lifting_index array_index es =
match es with
| [] -> lift lifting_index (self#visit_expr_w () e2)
| e :: es -> (
let array_index_ =
with_type H.usize (EConstant (SizeT, string_of_int array_index))
in
let lhs_i =
with_type (H.assert_tbuf_or_tarray lhs.typ) (EBufRead (lhs, array_index_))
in
match e.typ with
| TArray (_, n) ->
with_type e2.typ
(self#remove_assign n (lift lifting_index lhs_i) (lift lifting_index e)
(nest lifting_index (array_index + 1) es))
| _ ->
with_type e2.typ
(ELet
( H.sequence_binding (),
H.with_unit (EAssign (lift lifting_index lhs_i, lift lifting_index e)),
nest (lifting_index + 1) (array_index + 1) es )))
in
(nest 0 0 es).node
end
| _ ->
(* Something else, e.g. a variable -- generate a memcpy *)
let zero = Krml.(Helpers.zero Constant.SizeT) in
let rhs = self#visit_expr_w () rhs in
let lhs = self#visit_expr_w () lhs in
ELet
( H.sequence_binding (),
H.with_unit (EBufBlit (rhs, zero, lhs, zero, PreCleanup.expr_of_constant n)),
lift 1 (self#visit_expr_w () e2) )
method! visit_ELet (((), _) as env) b e1 e2 =
match b.typ, e1.node with
(* INVALID INITIALIZATION: let b = e1 in e2 -- explode into assignments, recursively *)
| TArray (_, n), _ when not (is_suitable_array_initializer e1.node) ->
(* let b = in *)
ELet
( b,
H.any,
(* b := *)
with_type e2.typ
(self#remove_assign n (with_type b.typ (EBound 0)) (Krml.DeBruijn.lift 1 e1)
(* e2 *)
(self#visit_expr env e2)) )
(* COPY: let _ = lhs := rhs with lhs.typ == TArray _ ... *)
| _, EAssign (lhs, rhs) when H.is_array lhs.typ ->
let n =
match lhs.typ with
| TArray (_, n) -> n
| _ -> failwith "impossible"
in
(* Fixpoint here for multi-dimensional arrays. *)
self#remove_assign n lhs rhs (subst H.eunit 0 e2)
| _ -> super#visit_ELet env b e1 e2
method! visit_EAssign env lhs rhs =
(* COPY: lhs := rhs with lhs.typ == TArray _ ... *)
match lhs.typ with
| TArray (_, n) -> self#remove_assign n lhs rhs H.eunit
| _ -> super#visit_EAssign env lhs rhs
end
let remove_array_temporaries =
object (self)
inherit [_] map as _super
method! visit_ELet (((), _) as env) b e1 e2 =
(* let x: TArray (t, n) = any;
blit (src, 0, dst, 0, n); // same length
x
~~>
src
*)
match snd !(b.node.mark), b.typ, e1.node, e2.node with
| ( AtMost 2,
TArray (_, l),
EAny,
ESequence
[
{
node =
EBufBlit
( src,
{ node = EConstant (_, "0"); _ },
{ node = EBound 0; _ },
{ node = EConstant (_, "0"); _ },
{ node = EConstant l'; _ } );
_;
};
{ node = EBound 0; _ };
] )
when l = l' -> (subst H.eunit 0 src).node
| _ -> ELet (b, self#visit_expr env e1, self#visit_expr env e2)
end
(* We remove array repeat expressions.
Such expressions might occur in any position; we rewrite everything into a
single form let x = [e; n] with a let-binding. (The later hoist phase is
going to do this anyhow, so we might as well do it now for simplicity.)
- If the array repeat is made up of zeroes, or array repeats made of zeroes,
then we generate (complete) initializer lists that the subsequent code-gen
in CStarToC will be able to emit as = { 0 } (note that this works because
we ensure such expressions are let-bound.) We could expand and generate
EBufCreateL nodes for *any* array repeat whose bounds are statically known,
but that's generally a bad idea.
- If the array repeat is of a /simple form/ (i.e., e is a scalar value), then
we use the BufCreate node, to be emitted later on (also in CStarToC) as a
zero-initializer, a memset, or a for-loop.
- Barring that, we use a for-loop and recurse.
This happens BEFORE remove_implicit_array_copies above. *)
let remove_array_repeats =
object (self)
inherit [_] map as super
method! visit_EApp env e es =
(* This is the case where the declaration is not in let-binding position. This happens with
e.g. `fn init() -> ... { [0; 32] }`. *)
match e.node, es with
| ETApp ({ node = EQualified lid; _ }, [ _ ], _, [ _ ]), [ _ ]
when lid = Builtin.array_repeat.name ->
(* Same logic as below: if we can do something smart (like, only zeroes), then we expand,
let the subsequent `hoist` phase lift this into a let-binding, and code-gen will optimize this into
{ 0 }. If we can't do something smart, we let-bind, and fall back onto the general case. *)
begin
try (self#expand_repeat (fst env) (with_type (snd env) (EApp (e, es)))).node
with Not_found ->
(self#visit_expr env
(with_type (snd env)
(ELet
( H.fresh_binder "repeat_expression" (snd env),
with_type (snd env) (EApp (e, es)),
with_type (snd env) (EBound 0) ))))
.node
end
| _ -> super#visit_EApp env e es
method private assert_length len =
match len.node with
| EConstant (_, s) -> int_of_string s
| _ -> failwith "impossible"
method private is_arr_typ t =
match t with
| TQualified ([ s1 ], s2) -> s1 = "Eurydice" && String.sub s2 0 3 = "arr"
| _ -> false
(* This function recursively expands nested repeat expressions as initializer lists
(EBufCreateL) as long as the innermost initial value is a zero, otherwise, it throws
Not_found. For instance:
- [[0; 2]; 2] --> { {0, 0}, {0, 0} }.
- [[1; 2]; 2] --> error -- better code quality with a BufCreate expression which will give
rise to a for-loop initializer
We override this behavior when we're already underneath a visit_DGlobal -- here, we've already
committed to an initializer list (and Charon will suitably "fold" repeat expressions
automatically for us), so we might as well expand.
*)
method private expand_repeat under_global e =
match e.node with
| EApp
( { node = ETApp ({ node = EQualified lid; _ }, [ len ], _, [ _ ]); _ },
[ ({ node = EConstant (_, "0"); _ } as init) ] )
when lid = Builtin.array_repeat.name ->
(* [0; n] -> ok *)
with_type e.typ @@ EBufCreateL (Stack, List.init (self#assert_length len) (fun _ -> init))
| EApp
( { node = ETApp ({ node = EQualified lid; _ }, [ len ], _, [ _ ]); _ },
[ ({ node = EConstant _; _ } as init) ] )
when lid = Builtin.array_repeat.name && under_global ->
(* [c; n] -> get translated when we are under DGlobal *)
with_type e.typ @@ EBufCreate (Stack, init, Krml.Helpers.mk_sizet (self#assert_length len))
| EApp ({ node = ETApp ({ node = EQualified lid; _ }, [ len ], _, [ _ ]); _ }, [ init ])
when lid = Builtin.array_repeat.name ->
(* [e; n] -> ok if e ok -- n is a constant here Rust has no VLAs *)
let init = self#expand_repeat under_global init in
with_type e.typ @@ EBufCreateL (Stack, List.init (self#assert_length len) (fun _ -> init))
| EFlat [ (lido, e1) ] when lido = Some "data" && self#is_arr_typ e.typ ->
(* { .data = e } -> ok if e ok *)
let e1 = self#expand_repeat under_global e1 in
with_type e.typ (EFlat [ lido, e1 ])
| EBufCreateL (l, es) when under_global ->
(* { e1, e2, ... en } -> get recursively expanded when are under DGlobal *)
with_type e.typ @@ EBufCreateL (l, List.map (self#expand_repeat true) es)
| _ ->
if under_global then
e
else
raise Not_found
method! visit_DGlobal _env flags name n t e1 = super#visit_DGlobal true flags name n t e1
method! visit_ELet ((under_global, _) as env) b e1 e2 =
match e1.node with
(* Nothing special here for EBufCreateL otherwise it breaks the invariant expected by
remove_implicit_array_copies *)
| EApp ({ node = ETApp ({ node = EQualified lid; _ }, [ len ], _, [ _ ]); _ }, [ init ])
when lid = Builtin.array_repeat.name -> begin
try
(* Case 1 (only zeroes). *)
let r = ELet (b, (self#expand_repeat under_global) e1, self#visit_expr env e2) in
r
with Not_found -> (
match init.node with
| EConstant _ ->
(* Case 2. *)
let e1 =
with_type e1.typ
(EBufCreate (Stack, init, Krml.Helpers.mk_sizet (self#assert_length len)))
in
ELet (b, e1, self#visit_expr env e2)
| _ ->
(* Case 3. *)
(* let b = [ init; len ] *)
let module H = Krml.Helpers in
let len = self#visit_expr env len in
let init = self#visit_expr env init in
(* let b; *)
ELet
( b,
H.any,
(* let _ = *)
with_type e2.typ
(ELet
( H.sequence_binding (),
(* for *)
H.with_unit
(EFor
( Krml.Helpers.fresh_binder ~mut:true "i" H.usize,
H.zero_usize (* i = 0 *),
H.mk_lt_usize (Krml.DeBruijn.lift 2 len) (* i < len *),
H.mk_incr_usize (* i++ *),
let i = with_type H.usize (EBound 0) in
let b = with_type b.typ (EBound 1) in
let b_i =
with_type (H.assert_tbuf_or_tarray b.typ) (EBufRead (b, i))
in
(* b[i] := init *)
H.with_unit (EAssign (b_i, Krml.DeBruijn.lift 2 init)) )),
(* e2 *)
Krml.DeBruijn.lift 1 (self#visit_expr env e2) )) ))
end
| _ -> super#visit_ELet env b e1 e2
end
let remove_array_from_fn files =
let defs =
Krml.Helpers.build_map files (fun tbl d ->
match d with
| DFunction (_, _, _, _, _, name, _, body) -> Hashtbl.add tbl name body
| _ -> ())
in
begin
object
inherit [_] map as super
method! visit_DFunction _ cc flags n_cgs n t name bs e =
assert (n_cgs = 0 && n = 0);
Hashtbl.add defs name e;
super#visit_DFunction () cc flags n_cgs n t name bs e
method! visit_EApp env e es =
match e.node with
| ETApp
( { node = EQualified ([ "core"; "array" ], "from_fn"); _ },
[ len ],
[ call_mut; _call_once ],
[ t_elements; _t_captured_state ] ) ->
L.log "Cleanup2" "%a %a" ptyp t_elements ptyp t_elements;
(* By translating array into struct, we return a struct of array for [from_fn] here *)
let state = Krml.KList.one es in
let t_struct, _ = Krml.Helpers.flatten_arrow e.typ in
let t_element, _ = Krml.Helpers.flatten_arrow call_mut.typ in
let t_array =
match len.node with
| EConstant c -> TArray (t_element, c)
| _ -> assert false
in
let x, dst_struct = H.mk_binding ~mut:true "arr_struct" t_struct in
let dst = with_type t_array (EField (dst_struct, "data")) in
let bindx = x, with_type t_struct EAny in
let t_dst = H.assert_tbuf_or_tarray t_array in
let for_assign =
let lift1 = Krml.DeBruijn.lift 1 in
with_type TUnit
(EFor
( Krml.Helpers.fresh_binder ~mut:true "i" H.usize,
H.zero_usize (* i: size_t = 0 *),
H.mk_lt_usize (Krml.DeBruijn.lift 1 len) (* i < len *),
H.mk_incr_usize (* i++ *),
let i = with_type H.usize (EBound 0) in
Krml.Helpers.with_unit
(EBufWrite
( lift1 dst,
i,
with_type t_dst
(EApp
( call_mut,
[
with_type (TBuf (state.typ, false)) (EAddrOf (lift1 state));
with_type (TInt SizeT) (EBound 0);
] )) )) ))
in
(H.nest [ bindx ] t_struct (with_type t_struct (ESequence [ for_assign; dst_struct ])))
.node
| ETApp
( { node = EQualified ("core" :: "array" :: _, "map"); _ },
[ len ],
[ call_mut; _call_once ],
ts ) ->
let t_src, t_dst =
match ts with
| [ t_src; t_state; t_dst ] ->
assert (t_state = TUnit);
L.log "Cleanup2" "found array map from %a to %a" ptyp t_src ptyp t_dst;
t_src, t_dst
| _ ->
failwith "TODO: unknown map closure shape; is it an array outparam? (see above)"
in
let e_src, e_state =
match es with
| [ e_src; e_state ] -> e_src, e_state
| _ -> failwith "unknown shape of arguments to array map"
in
let len_c =
match len.node with
| EConstant c -> c
| _ -> failwith "unable to get the const length for array map"
in
let lift1 = Krml.DeBruijn.lift 1 in
let e_state = with_type (TBuf (e_state.typ, false)) (EAddrOf (lift1 e_state)) in
let e_src = with_type (TArray (t_src, len_c)) (EField (e_src, "data")) in
let t_dst_str, _ = Krml.Helpers.flatten_arrow e.typ in
let t_dst_arr = TArray (t_dst, len_c) in
let x, dst_struct = H.mk_binding ~mut:true "arr_mapped_str" t_dst_str in
let e_dst = with_type t_dst_arr (EField (dst_struct, "data")) in
let bindx = x, with_type t_dst_str EAny in
let for_assign =
with_type TUnit
(EFor
( Krml.Helpers.fresh_binder ~mut:true "i" H.usize,
H.zero_usize (* i = 0 *),
H.mk_lt_usize (Krml.DeBruijn.lift 1 len) (* i < len *),
H.mk_incr_usize (* i++ *),
let i = with_type H.usize (EBound 0) in
let e_src_i = with_type t_src (EBufRead (lift1 e_src, i)) in
Krml.Helpers.with_unit
(EBufWrite
( lift1 e_dst,
i,
with_type t_dst (EApp (call_mut, [ lift1 e_state; e_src_i ])) )) ))
in
(H.nest [ bindx ] t_dst_str
(with_type t_dst_str (ESequence [ for_assign; dst_struct ])))
.node
| _ -> super#visit_EApp env e es
end
end
#visit_files
() files
let remove_trivial_into =
object (self)
inherit [_] map as _super
method! visit_EApp env e es =
let e = self#visit_expr_w () e in
let es = List.map (self#visit_expr env) es in
match e.node, es with
| ( ETApp ({ node = EQualified ([ "core"; "convert"; _ ], "into"); _ }, [], _, [ t1; t2 ]),
[ e1 ] )
when t1 = t2 -> e1.node
| ( ETApp
( { node = EQualified ([ "core"; "convert"; _ ], "into"); _ },
[],
_,
[ TInt _; (TInt _ as t2) ] ),
[ e1 ] ) -> ECast (e1, t2)
| _ -> EApp (e, es)
end
let remove_trivial_ite =
object (self)
inherit [_] map as super
method! visit_EIfThenElse (((), _) as env) e1 e2 e3 =
match e1.node with
| EApp
( { node = EOp (Eq, _); _ },
[ { node = EConstant (w1, c1); _ }; { node = EConstant (w2, c2); _ } ] )
when w1 = w2 ->
if int_of_string c1 = int_of_string c2 then
(self#visit_expr env e2).node
else
(self#visit_expr env e3).node
| EBool true -> (self#visit_expr env e2).node
| EBool false -> (self#visit_expr env e3).node
| _ -> super#visit_EIfThenElse env e1 e2 e3
method! visit_ESwitch env scrut branches =
let const_eq (w1, s1) (w2, s2) = w1 = w2 && int_of_string s1 = int_of_string s2 in
let fits s (w' : K.width) =
let s = Z.of_string s in
match w' with
| UInt8 -> Z.leq s (Z.of_string "0xff")
| UInt16 -> Z.leq s (Z.of_string "0xffff")
| UInt32 -> Z.leq s (Z.of_string "0xffffffff")
| UInt64 -> Z.leq s (Z.of_string "0xffffffffffffffff")
| _ -> false (* conservative decision *)
in
let normalize = function
| ECast ({ node = EConstant (_, s); _ }, TInt w') when fits s w' -> EConstant (w', s)
| c -> c
in
match normalize scrut.node with
| EConstant c -> begin
match
List.find_opt
(function
| SConstant c', _ -> const_eq c c'
| _ -> false)
branches
with
| Some (_, b) -> (self#visit_expr env b).node
| None -> begin
match List.find_opt (fun (sv, _) -> sv = SWild) branches with
| Some (_, b) -> (self#visit_expr env b).node
| None ->
assert (snd env = TUnit);
EUnit
end
end
| _ -> super#visit_ESwitch env scrut branches
end
let contains_array t =
begin
object (_self)
inherit [_] reduce as _super
method zero = false
method plus = ( || )
method! visit_TBuf _ _ _ = false
method! visit_TArray _ _ _ = true
method! visit_TCgArray _ _ _ = true
end
end
#visit_expr_w
() t
let must_explode e =
(* Note that this visits the whole type (including the type of fields) *)
contains_array e && not (is_suitable_array_initializer e.node)
let remove_literals tbl =
object (_self)
inherit [_] map as super_map
inherit! Krml.Structs.remove_literals tbl as super_krml
method! visit_ELet env b e1 e2 =
if must_explode e1 then
super_krml#visit_ELet env b e1 e2
else
super_map#visit_ELet env b e1 e2
method! visit_EFlat (((), t) as env) fields =
if must_explode (with_type t (EFlat fields)) then
super_krml#visit_EFlat env fields
else
super_map#visit_EFlat env fields
method! visit_DGlobal _env flags name n t body =
(* No point: can't have let-bindings in globals *)
DGlobal (flags, name, n, t, body)
end
let remove_literals files =
(remove_literals (Krml.Structs.build_remove_literals_map files))#visit_files () files
let build_macros (macros : Krml.Idents.LidSet.t ref) =
object (_self)
inherit [_] map as super
method! visit_DGlobal env flags name n t body =
(if List.mem Krml.Common.Macro flags then
macros := Krml.Idents.LidSet.(union !macros (singleton name)));
super#visit_DGlobal env flags name n t body
end
let build_macros files =
let map = ref Krml.Idents.LidSet.empty in
let files = (build_macros map)#visit_files () files in
files, !map
let rec ends_with pred e =
match e.node with
| EIfThenElse (_, e1, e2) -> ends_with pred e1 && ends_with pred e2
| EMatch (_, _, es) -> List.for_all (fun (_, _, e) -> ends_with pred e) es
| ELet (_, _, e) -> ends_with pred e
| ESequence es -> ends_with pred (Krml.KList.last es)
| _ -> pred e
let ends_with_continue =
ends_with (fun n ->
match n.node with
| EContinue -> true
| _ -> false)
let ends_with_return =
ends_with (fun n ->
match n.node with
| EReturn _ -> true
| _ -> false)
let resugar_loops =
object(self)
inherit [_] map as super
method! visit_expr ((), _ as env) e =
let open Krml.Helpers in
let step_by = match e with
(* Non-terminal position (step-by for-loop) *)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter<
core::iter::adapters::step_by::StepBy>,
?..
>(core::iter::range::?::step_by..>(
{ start: ?e_start, end: ?e_end },
?e_increment
));
while true {
let x = core::iter::adapters::step_by::?::next, ?t1>(&iter);
match x {
None -> break,
Some ? -> ?e_body
}
};
?rest..
|}] ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = Krml.DeBruijn.subst e_some_i 0 e_body in
Some (t1, e_start, e_end, e_increment, [e_body], rest)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter<
core::iter::adapters::step_by::StepBy>,
?..
>(core::iter::range::?::step_by..>(
{ start: ?e_start, end: ?e_end },
?e_increment
));
while true {
let x = core::iter::adapters::step_by::?::next, ?t1>(&iter);
match x {
None -> break,
Some ? -> ?e_body
};
?loop_rest..
};
?rest..
|}] ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = List.map (Krml.DeBruijn.subst e_some_i 0) (e_body :: loop_rest) in
Some (t1, e_start, e_end, e_increment, e_body, rest)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter<
core::iter::adapters::step_by::StepBy>,
?..
>(core::iter::range::?::step_by..>(
{ start: ?e_start, end: ?e_end },
?e_increment
));
while true {
match (core::iter::adapters::step_by::?::next, ?t1>(&iter)) {
None -> break,
Some ? -> ?e_body
}
};
?rest..
|}] -> Some (t1, e_start, e_end, e_increment, [e_body], rest)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter<
core::iter::adapters::step_by::StepBy>,
?..
>(core::iter::range::?::step_by..>(
{ start: ?e_start, end: ?e_end },
?e_increment
));
while true {
match (core::iter::adapters::step_by::?::next, ?t1>(&iter)) {
None -> break,
Some ? -> ?e_body
};
?loop_rest..
};
?rest..
|}] -> Some (t1, e_start, e_end, e_increment, e_body :: loop_rest, rest)
(* Terminal position (step-by for-loop) *)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter<
core::iter::adapters::step_by::StepBy>,
?..
>(core::iter::range::?::step_by..>(
{ start: ?e_start, end: ?e_end },
?e_increment
));
while true {
let x = core::iter::adapters::step_by::?::next, ?t1>(&iter);
match x {
None -> break,
Some ? -> ?e_body
}
}
|}] ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = Krml.DeBruijn.subst e_some_i 0 e_body in
Some (t1, e_start, e_end, e_increment, [e_body], [])
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter<
core::iter::adapters::step_by::StepBy>,
?..
>(core::iter::range::?::step_by..>(
{ start: ?e_start, end: ?e_end },
?e_increment
));
while true {
let x = core::iter::adapters::step_by::?::next, ?t1>(&iter);
match x {
None -> break,
Some ? -> ?e_body
};
?loop_rest..
}
|}] ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = List.map (Krml.DeBruijn.subst e_some_i 0) (e_body :: loop_rest) in
Some (t1, e_start, e_end, e_increment, e_body, [])
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter<
core::iter::adapters::step_by::StepBy>,
?..
>(core::iter::range::?::step_by..>(
{ start: ?e_start, end: ?e_end },
?e_increment
));
while true {
match (core::iter::adapters::step_by::?::next, ?t1>(&iter)) {
None -> break,
Some ? -> ?e_body
}
}
|}] -> Some (t1, e_start, e_end, e_increment, [e_body], [])
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter<
core::iter::adapters::step_by::StepBy>,
?..
>(core::iter::range::?::step_by..>(
{ start: ?e_start, end: ?e_end },
?e_increment
));
while true {
match (core::iter::adapters::step_by::?::next, ?t1>(&iter)) {
None -> break,
Some ? -> ?e_body
};
?loop_rest..
}
|}] -> Some (t1, e_start, e_end, e_increment, e_body :: loop_rest, [])
| _ -> None
in
let range_iter = match e with
(* Terminal position (regular range for-loop) *)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
let x = core::iter::range::?::next(&iter);
match x {
None -> break,
Some ? -> ?e_body
}
}
|}] ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = Krml.DeBruijn.subst e_some_i 0 e_body in
Some (t1, e_start, e_end, [e_body], [])
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
let x = core::iter::range::?::next(&iter);
match x {
None -> break,
Some ? -> ?e_body
};
?loop_rest..
}
|}] ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = List.map (Krml.DeBruijn.subst e_some_i 0) (e_body :: loop_rest) in
Some (t1, e_start, e_end, e_body, [])
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
match (core::iter::range::?::next(&iter)) {
None -> break,
Some ? -> ?e_body
}
}
|}] -> Some (t1, e_start, e_end, [e_body], [])
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
match (core::iter::range::?::next(&iter)) {
None -> break,
Some ? -> ?e_body
};
?loop_rest..
}
|}] -> Some (t1, e_start, e_end, e_body :: loop_rest, [])
(* Non-terminal position (regular range for-loop) *)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
let x = core::iter::range::?::next(&iter);
match x {
None -> break,
Some ? -> ?e_body
}
};
?rest..
|}] ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = Krml.DeBruijn.subst e_some_i 0 e_body in
Some (t1, e_start, e_end, [e_body], rest)
(* Non-terminal position (regular range for-loop) *)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
let x = core::iter::range::?::next(&iter);
match x {
None -> break,
Some ? -> ?e_body
};
?loop_rest..
};
?rest..
|}] ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = List.map (Krml.DeBruijn.subst e_some_i 0) (e_body :: loop_rest) in
Some (t1, e_start, e_end, e_body, rest)
(* Special variant that appears in external crates -- TODO: do we need variants of all other
patterns? *)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
let x = core::iter::range::?::next(&iter);
match x {
None -> ?e2,
Some ? -> ?e_body
};
abort
}
|}] when ends_with_return e2 && ends_with_continue e_body
(* && x does not appear in e2 *) ->
let e_some_i = with_type (Builtin.mk_option t1) (ECons ("Some", [with_type t1 (EBound 0)])) in
let e_body = Krml.DeBruijn.subst e_some_i 0 e_body in
Some (t1, e_start, e_end, [e_body], [])
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
match (core::iter::range::?::next(&iter)) {
None -> break,
Some ? -> ?e_body
}
};
?rest..
|}] -> Some (t1, e_start, e_end, [e_body], rest)
| [%cremepat {|
let iter =
core::iter::traits::collect::?::into_iter
, ?..>
({ start: ?e_start, end: ?e_end });
while true {
match (core::iter::range::?::next(&iter)) {
None -> break,
Some ? -> ?e_body
};
?loop_rest..
};
?rest..
|}] -> Some (t1, e_start, e_end, e_body :: loop_rest, rest)
| _ -> None
in
match step_by with
| Some (t1, e_start, e_end, e_increment, e_body, rest) ->
let w = match t1 with TInt w -> w | _ -> assert false in
with_type e.typ @@
ESequence (
with_type TUnit (EFor (
fresh_binder ~mut:true "i" t1,
e_start,
mk_lt w (Krml.DeBruijn.lift 1 e_end),
(* XXX seems like the increment is always size_t here ?! *)
mk_incr_e w (with_type t1 (ECast (e_increment, t1))),
with_type TUnit (ESequence (
List.map (self#visit_expr env) e_body
))
)) :: List.map (fun e -> self#visit_expr env (Krml.DeBruijn.subst eunit 0 e)) rest
)
| None -> begin match range_iter with
| Some (t1, e_start, e_end, e_body, rest) ->
let w = match t1 with TInt w -> w | _ -> assert false in
with_type e.typ @@ ESequence (
with_type TUnit (EFor (
fresh_binder ~mut:true "i" t1,
e_start,
mk_lt w (Krml.DeBruijn.lift 1 e_end),
mk_incr w,
with_type TUnit (ESequence (
List.map (self#visit_expr env) e_body
))
)) :: List.map (fun e -> self#visit_expr env (Krml.DeBruijn.subst eunit 0 e)) rest
)
| None -> super#visit_expr env e
end
end
[@ocamlformat "disable"]
let improve_names files =
let renamed = Hashtbl.create 41 in
let allocated = Hashtbl.create 41 in
(object (_self)
inherit [_] iter
method! visit_DFunction _ _ _ _ _ _ ((m, n) as lid) _ _ =
let trait_impl, m = List.partition (fun s -> s.[0] = '{') m in
match trait_impl with
| [ trait_impl ] ->
let hash = Hashtbl.hash trait_impl in
let n = Printf.sprintf "%s_%02x" n (hash land 0xFF) in
Krml.Monomorphization.maybe_debug_hash hash
(lazy PPrint.(string "trait impl:" ^/^ string trait_impl));
let n = Krml.Idents.mk_fresh n (fun n -> Hashtbl.mem allocated (m, n)) in
Hashtbl.add renamed lid ((m, n), trait_impl);
Hashtbl.add allocated (m, n) ()
| _ -> ()
end)
#visit_files
() files;
(* Hashtbl.iter (fun k (v, _) -> *)
(* Krml.KPrint.bprintf "%a --> %a\n" plid k plid v *)
(* ) renamed; *)
(* TODO: are there other global maps like this whose lids need to be
updated??? *)
Krml.Options.static_header :=
List.map
(function
| Krml.Bundle.Lid lid when Hashtbl.mem renamed lid ->
Krml.Bundle.Lid (fst (Hashtbl.find renamed lid))
| x -> x)
!Krml.Options.static_header;
(object (self)
inherit [_] map
method! visit_DFunction env cc flags n_cgs n t lid bs e =
match Hashtbl.find_opt renamed lid with
| Some (lid, trait_impl) ->
let comment = Krml.KPrint.bsprintf "This function found in impl %s" trait_impl in
DFunction (cc, flags @ [ Comment comment ], n_cgs, n, t, lid, bs, self#visit_expr_w env e)
| None -> DFunction (cc, flags, n_cgs, n, t, lid, bs, self#visit_expr_w env e)
method! visit_EQualified _ lid =
EQualified
(match Hashtbl.find_opt renamed lid with
| Some (lid, _) -> lid
| None -> lid)
end)
#visit_files
() files
let recognize_asserts =
object (_self)
inherit [_] map as super
method! visit_EIfThenElse (((), _) as env) e1 e2 e3 =
match e1.typ, e2.node, e3.node with
| TBool, EUnit, EAbort (_, msg) ->
(* if e1 then () else abort msg --> static_assert(e1, msg) *)
EApp
( Builtin.static_assert_ref,
[ e1; with_type Krml.Checker.c_string (EString (Option.value ~default:"" msg)) ] )
| TBool, EAbort (_, msg), EUnit ->
(* if not (e1) then abort msg else () --> static_assert(e1, msg) *)
EApp
( Builtin.static_assert_ref,
[
Krml.Helpers.mk_not e1;
with_type Krml.Checker.c_string (EString (Option.value ~default:"" msg));
] )
| _ -> super#visit_EIfThenElse env e1 e2 e3
end
(* Reconstructing for-loops from while nodes introduced by c_for!. *)
class iter_counting =
object
(* The environment [i] has type [int]. *)
inherit [_] iter
(* The environment [i] keeps track of how many binders have been
entered. It is incremented at each binder. *)
method! extend i (_ : binder) = i + 1
end
(* De Bruijn index i is found in expression e *)
let found i e =
let exception Found in
let find =
object
inherit iter_counting
method! visit_EBound (i, _) j =
if i = j then
raise Found
end
in
try
find#visit_expr_w i e;
false
with Found -> true
let smallest =
object
inherit [_] reduce
method zero = max_int
method plus x y = min x y
method visit_EBound _ i = i
end
let rec find_terminal_incr i e =
if e.typ <> TUnit && e.typ <> TAny then
Krml.Warn.failwith "e_then has type: %a\n" ptyp e.typ;
let ( let* ) = Option.bind in
let hoist e = Krml.DeBruijn.subst_n e (List.init i (fun _ -> Krml.Helpers.eunit)) in
match e.node with
| ELet (b, e1, e2) ->
let* e2, e_incr = find_terminal_incr (i + 1) e2 in
Some ({ e with node = ELet (b, e1, e2) }, e_incr)
| ESequence es ->
let es, e_incr = Krml.KList.split_at_last es in
let nearest = smallest#visit_expr_w () e_incr in
if nearest < i then
None
else
Some ({ e with node = ESequence es }, hoist e_incr)
| _ ->
let nearest = smallest#visit_expr_w () e in
if nearest < i then
None
else
Some (Krml.Helpers.eunit, hoist e)
let reconstruct_for_loops =
let no_control_flow (e : expr) =
match e.node with
| EWhile _ | EFor _ | ELet _ | EFun _ | EIfThenElse _ | ESequence _ | EMatch _ | ESwitch _ ->
false
| _ -> true
in
object (self)
inherit [_] map as super
method! visit_ELet (((), _) as env) b e1 e2 =
match e1.node, e1.typ, e2.node with
(* t x = e1; while (true) { if (e_cond) { ...; e_incr } else { break; } *)
| ( _,
_,
EWhile
( { node = EBool true; _ },
{ node = EIfThenElse (e_cond, e_then, { node = EBreak; _ }); _ } ) ) -> begin
match find_terminal_incr 0 e_then with
| Some (e_then, e_incr) when no_control_flow e_incr ->
let e_then = self#visit_expr env e_then in
EFor (b, e1, e_cond, e_incr, e_then)
| _ -> super#visit_ELet env b e1 e2
end
(* let t x = e1 in
let _ = while (true) { if (e_cond) { e_then; e_incr } else { break; } in
e2
~~~>
let _ = for (t x = e1; e_cond; e_incr) { e_then } in
e2 *)
| ( _,
_,
ELet
( _,
{
node =
EWhile
( { node = EBool true; _ },
{ node = EIfThenElse (e_cond, e_then, { node = EBreak; _ }); _ } );
_;
},
e2' ) )
when not (found 1 e2') -> begin
match find_terminal_incr 0 e_then with
| Some (e_then, e_incr) when no_control_flow e_incr ->
let e_then = self#visit_expr env e_then in
let e2 = self#visit_expr env e2' in
let shift1 = Krml.(DeBruijn.subst Helpers.eunit 0) in
ELet
( Krml.Helpers.sequence_binding (),
with_type TUnit (EFor (b, e1, e_cond, e_incr, e_then)),
shift1 e2 )
| _ -> super#visit_ELet env b e1 e2
end
| _ -> super#visit_ELet env b e1 e2
method! visit_EWhile env e1 e2 =
(* while (true) { if (e_cond) { e_then } else { break } } ~~>
while (e_cond) { e_then } *)
match e1.node, e2.node with
| EBool true, EIfThenElse (e_cond, e_then, { node = EBreak; _ }) ->
EWhile (e_cond, self#visit_expr env e_then)
| _ -> super#visit_EWhile env e1 e2
(* method! visit_DFunction _ cc flags n_cgs n t name bs e = *)
(* Krml.KPrint.bprintf "for-loop reconstruction: visiting %a\n" plid name; *)
(* super#visit_DFunction () cc flags n_cgs n t name bs e *)
end
let remove_assign_return =
object (self)
inherit [_] map as super
method! visit_ESequence (((), _) as env) es =
match List.rev es with
| { node = EReturn { node = EBound i; _ }; typ = t; _ }
:: { node = EAssign ({ node = EBound i'; _ }, e); _ }
:: es
when i = i' ->
ESequence (List.rev (with_type t (EReturn e) :: List.map (self#visit_expr env) es))
| { node = EBound i; _ } :: { node = EAssign ({ node = EBound i'; _ }, e); _ } :: es
when i = i' -> ESequence (List.rev (e :: List.map (self#visit_expr env) es))
| _ -> super#visit_ESequence env es
end
let bonus_cleanups =
let open Krml in
object (self)
inherit [_] map as super
method! extend env b = b.node.name :: env
method! visit_lident _ lid =
match lid with
| [ "core"; "slice"; "{[T]}" ], "len" -> [ "Eurydice" ], "slice_len"
| [ "core"; "slice"; "{[T]}" ], "copy_from_slice" -> [ "Eurydice" ], "slice_copy"
| [ "core"; "slice"; "{[T]}" ], "split_at" -> [ "Eurydice" ], "slice_split_at"
| [ "core"; "slice"; "{[T]}" ], "split_at_mut" -> [ "Eurydice" ], "slice_split_at_mut"
| _ -> lid
(* { f = e; ... }.f ~~> e
scheduled late because we need all the let-inlining *)
method! visit_EField env e f =
match e.node with
| EFlat fields -> (List.assoc (Some f) fields).node
| _ -> EField (self#visit_expr env e, f)
method! visit_ELet ((bs, _) as env) b e1 e2 =
match e1.node, e1.typ, e2.node with
(* let x; x := e; return x --> x*)
| ( EAny,
_,
ESequence [ { node = EAssign ({ node = EBound 0; _ }, e3); _ }; { node = EBound 0; _ } ] )
-> (DeBruijn.subst Helpers.eunit 0 e3).node
(* let uu; memcpy(uu, ..., src, ...); e2 --> let copy_of_src; ... *)
| ( EAny,
TArray (_, (_, n)),
ESequence
[
{
node =
EBufBlit
( { node = EBound src; _ },
{ node = EConstant (_, "0"); _ },
{ node = EBound 0; _ },
{ node = EConstant (_, "0"); _ },
{ node = EConstant (_, n'); _ } );
_;
};
_;
] )
when n = n' && Krml.Helpers.is_uu b.node.name ->
super#visit_ELet env
{
b with
node = { b.node with name = "copy_of_" ^ List.nth bs (src - 1) };
meta = [ CommentBefore "Passing arrays by value in Rust generates a copy in C" ];
}
e1 e2
(* let uu = f(e); y = uu; e2 --> let y = f(e); e2 *)
| ( EApp ({ node = EQualified _; _ }, es),
_,
ESequence [ { node = EAssign (e2, { node = EBound 0; _ }); _ }; e3 ] )
when Helpers.is_uu b.node.name && List.for_all Helpers.is_readonly_c_expression es ->
ESequence
[
with_type TUnit (EAssign (DeBruijn.subst Helpers.eunit 0 e2, e1));
self#visit_expr env (DeBruijn.subst Helpers.eunit 0 e3);
]
| _ -> super#visit_ELet env b e1 e2
end
let cosmetic =
object (_self)
inherit [_] map as super
method! visit_expr _ e =
match e with
| [%cremepat {| core::slice::?impl::len>(Eurydice::array_to_slice_shared[#?n]>(?)) |}]
when impl = "{[T]}" -> n
| [%cremepat {| core::slice::?impl::len>(Eurydice::array_to_slice_mut[#?n]>(?)) |}]
when impl = "{[T]}" -> n
| [%cremepat {| core::slice::?impl::len>(?e) |}] when impl = "{[T]}" ->
with_type (TInt SizeT) (EField (e, "meta"))
| [%cremepat {| Eurydice::slice_index_mut(?s, ?i) |}] ->
with_type e.typ
(EBufRead (with_type (TBuf (t, false)) (EField (super#visit_expr_w () s, "ptr")), i))
| [%cremepat {| Eurydice::slice_index_shared(?s, ?i) |}] ->
with_type e.typ
(EBufRead (with_type (TBuf (t, true)) (EField (super#visit_expr_w () s, "ptr")), i))
| _ -> super#visit_expr ((), e.typ) e
end
(* This is a potentially tricky phase because if it's too aggressive, it'll
generate a copy -- for instance, f(&x[3]) is not the same as let tmp = x[3];
f(&tmp). Such cases might be hidden behind macros! (Like
Eurydice_slice_index.) *)
let check_addrof =
object (self)
inherit [_] map
method! visit_EAddrOf ((), t) e =
(* see https://en.cppreference.com/w/c/language/operator_member_access *)
match e.node with
| EQualified _ (* case 1 *) | EBufRead _ (* case 4 *) -> EAddrOf (self#visit_expr_w () e)
| EApp ({ node = EQualified lid; _ }, _)
| EApp ({ node = ETApp ({ node = EQualified lid; _ }, _, _, _); _ }, _)
when lid = Builtin.slice_index_shared.name
|| lid = Builtin.slice_index_mut.name
|| Krml.KString.starts_with (snd lid) "op_Bang_Star__" (* case 4, case 3 *) ->
EAddrOf e
| _ ->
(* Recursively do for the internal expression first *)
let e = self#visit_expr_w () e in
if Krml.Structs.will_be_lvalue e then
EAddrOf e
else
let b = Krml.Helpers.fresh_binder ~mut:true "lvalue" e.typ in
let b =
{
b with
Krml.Ast.meta = [ CommentBefore "original Rust expression is not an lvalue in C" ];
}
in
ELet (b, e, with_type t (EAddrOf (with_type e.typ (EBound 0))))
end
(* Aeneas requires hoisting loop bodies into separate functions. *)
let is_inline_loop lid = Krml.KString.exists (snd lid) "inner_loop"
let return_becomes_break =
object
inherit [_] Krml.Ast.map as super
method! visit_EReturn _ _ = EBreak
method! visit_EFor _ _ _ _ = failwith "nested loop in a loop body"
method! visit_EApp env e es =
match e.node with
| EQualified lid when is_inline_loop lid -> failwith "nested loop in a loop body"
| _ -> super#visit_EApp env e es
end
let inline_loops =
object
inherit [_] Krml.Ast.map
method! visit_DFunction () cc flags n_cgs n t name binders body =
if is_inline_loop name then
DFunction
( cc,
[ Krml.Common.MustInline; MustDisappear ] @ flags,
n_cgs,
n,
t,
name,
binders,
return_becomes_break#visit_expr_w () body )
else
DFunction (cc, flags, n_cgs, n, t, name, binders, body)
end
(** A better version of hoist (than [Krml.Simplify.hoist]), also work for [DGlobal]. *)
let hoist =
object
inherit Krml.Simplify.hoist
method! visit_DGlobal loc flags name n ret expr =
let loc = Krml.Loc.(InTop name :: loc) in
let lhs, expr = Krml.Simplify.maybe_hoist_initializer field_types loc ret expr in
let expr = H.nest lhs ret expr in
DGlobal (flags, name, n, ret, expr)
end
(** Also fix for [DGlobal] as [hoist] above *)
let fixup_hoist =
object
inherit [_] map
method! visit_DFunction _ cc flags n_cgs n ret name binders expr =
DFunction (cc, flags, n_cgs, n, ret, name, binders, Krml.Simplify.fixup_return_pos expr)
method! visit_DGlobal () flags name n ret expr =
DGlobal (flags, name, n, ret, Krml.Simplify.fixup_return_pos expr)
end
(** For any [DGlobal], if the expression has any locals remaining We should let them also be
globals, so to make the overall expr valid.
I.e., we make: [T VAL = let v1 : T1 = e1 in let v2 : T2 = e2 in ... let vN : TN = eN in e;]
become:
[T1 VAL_local_1 = e1; T2 VAL_local_2 = e2[v1/VAL_local_1]; ... TN VAL_local_N =
eN[v1/VAL_local_1; v2/VAL_local_2; ...; vN-1/VAL_local_(N-1)]; T VAL = e;]
Notably, the locals should be renamed to avoid potential naming conflicts. *)
let globalize_global_locals files =
let mapper = function
| DGlobal (flags, name, n_cgs, ty, expr) ->
let rec decompose_expr id info_acc expr =
match expr.node with
| ELet (_, e1, e2) ->
let name =
let lst, name = name in
lst, name ^ "$local$" ^ string_of_int id
in
(* Replace the variable with the new globalised name. *)
let e2 = subst Krml.Ast.(with_type e1.typ (EQualified name)) 0 e2 in
decompose_expr (id + 1) ((name, e1) :: info_acc) e2
| _ -> List.rev info_acc, expr
in
let info, expr = decompose_expr 0 [] expr in
(* Make the new globals private if possible -- with exception that
if it is a non-private macro, then the involved new globals should not be private *)
let module NameSet = Krml.Idents.LidSet in
let no_priv_names =
if List.mem Krml.Common.Macro flags && not (List.mem Krml.Common.Private flags) then
(object
inherit [_] reduce
method private zero = NameSet.empty
method private plus = NameSet.union
method! visit_EQualified _ name = NameSet.singleton name
end)
#visit_expr_w
() expr
else
NameSet.empty
in
let make_decl (name, expr) =
let flags =
if NameSet.mem name no_priv_names then
[]
else
[ Krml.Common.Private ]
in
DGlobal (flags, name, n_cgs, expr.typ, expr)
in
List.map make_decl info @ [ DGlobal (flags, name, n_cgs, ty, expr) ]
| decl -> [ decl ]
in
List.map (fun (name, decls) -> name, List.concat_map mapper decls) files
(* The elimination of single-field structs generates new types equations, which
we need to substitute away. *)
let fixup_monomorphization_map map =
(* Replace all occurences of lid, a struct that had a single field of type t,
with t *)
let replace =
object (self)
inherit [_] Krml.Ast.map
method! visit_TQualified () lid =
match Hashtbl.find_opt map lid with
| Some (Krml.DataTypes.Eliminate t) -> self#visit_typ () t
| _ -> TQualified lid
end
in
(* Must convert the hashtbl keys to a list instead of a lazy sequence Seq,
because this would result in modifying the hashtbl while accessing it. *)
List.iter
(fun ((lid, ts, cgs), v) ->
let ts = List.map (replace#visit_typ ()) ts in
Hashtbl.add Krml.MonomorphizationState.state (lid, ts, cgs) v)
(List.of_seq (Hashtbl.to_seq Krml.MonomorphizationState.state))
(* Hoist comments to be attached to the nearest statement *)
let float_comments files =
let comments = ref [] in
let prepend c = comments := c :: !comments in
let flush () =
let r = List.rev !comments in
comments := [];
List.map (fun x -> CommentBefore x) r
in
let filter_meta meta =
meta
|> List.filter (function
| CommentBefore c ->
prepend c;
false
| _ -> true)
|> List.filter (function
| CommentAfter c ->
prepend c;
false
| _ -> true)
in
(object (self)
inherit [_] map as super
method! visit_expr env e =
let e = super#visit_expr env e in
{ e with meta = filter_meta e.meta }
method private process_block e =
let float_one e =
let e = self#visit_expr_w () e in
{ e with meta = flush () }
in
match e.node with
| ELet (b, e1, e2) ->
let e1 = self#visit_expr_w () e1 in
let e1 = { e1 with meta = filter_meta e1.meta } in
let b = { b with meta = filter_meta b.meta } in
let meta = flush () in
{ e with node = ELet (b, e1, self#process_block e2); meta }
| ESequence es ->
let es = List.map float_one es in
{ e with node = ESequence es; meta = filter_meta e.meta }
| _ -> float_one e
method! visit_EFor env b e1 e2 e3 e4 =
let e4 = self#process_block e4 in
EFor (b, self#visit_expr env e1, self#visit_expr env e2, self#visit_expr env e3, e4)
method! visit_EWhile env e1 e2 =
let e2 = self#process_block e2 in
EWhile (self#visit_expr env e1, e2)
method! visit_EIfThenElse env e1 e2 e3 =
let e2 = self#process_block e2 in
let e3 = self#process_block e3 in
EIfThenElse (self#visit_expr env e1, e2, e3)
method! visit_ESwitch env e bs =
let bs = List.map (fun (c, e) -> c, self#process_block e) bs in
ESwitch (self#visit_expr env e, bs)
method! visit_DFunction _ cc flags n_cgs n t name bs e =
DFunction (cc, flags, n_cgs, n, t, name, bs, self#process_block e)
end)
#visit_files
() files
(* When krml is used with the F* frontend, all operations on signed integers
must fit in the destination type -- no overflow allowed!
When krml is used with the Rust frontend (here), overflow on signed integer
types is UB, except for left-shift which *is* defined (provided the places we
shift by do not exceed the width of the type, like in C).
We rely on the invariant that for signed integer arithmetic, every
subexpression may be as `int` as long as the representation is consistent
(i.e. the sign-extended version of the original value).
- add, mul, div: cannot overflow in Rust (panic)
- right-shift: ok (sign-extension in practice even though
implementation-defined)
- left-shift: must cast to unsigned to avoid UB, then cast back to signed to
clamp extra high bytes
*)
let rewrite_signed_shifts files =
let open Krml.Constant in
(object (self)
inherit [_] map as super
method! visit_EApp env e es =
match e.node, es with
| EOp (BShiftL, TInt w), [ e1; e2 ] when is_signed w ->
let unsigned_w = unsigned_of_signed w in
(* No point in casting to uint16 or uint8: this will be promoted to
`int` once in C, which AstToCStar defeats by casting to (uint32_t)
-- we simply anticipate this fact and cast straight to uint32_t. *)
let unsigned_w =
match unsigned_w with
| UInt8 | UInt16 -> UInt32
| _ -> unsigned_w
in
let e1 = self#visit_expr env e1 in
let e2 = self#visit_expr env e2 in
(* Note that in C, casting to a signed type is implementation-defined
(yay). We assume all implementations rely on two's complement. *)
let e1_unsigned = with_type (TInt unsigned_w) (ECast (e1, TInt unsigned_w)) in
let op_type = H.fold_arrow [ TInt unsigned_w; e2.typ ] (TInt unsigned_w) in
let shift =
with_type (TInt unsigned_w)
(EApp (with_type op_type (EOp (BShiftL, TInt unsigned_w)), [ e1_unsigned; e2 ]))
in
ECast (shift, TInt w)
| _ -> super#visit_EApp env e es
end)
#visit_files
() files
(* Now that we have the allocation scheme of data types, we can eliminate the Eurydice_discriminant
placeholder *)
let remove_discriminant_reads (map : Krml.DataTypes.map) files =
let lookup_tag_lid lid =
let open Krml.DataTypes in
match Hashtbl.find (fst3 map) lid with
| exception Not_found -> `Direct (* was compiled straight to an enum via AstOfLlbc *)
| ToEnum -> `Direct
| ToTaggedUnion branches | ToFlatTaggedUnion branches ->
let tags = List.map (fun (cons, _) -> cons, None) branches in
`TagField (Hashtbl.find (snd3 map) tags)
| _ ->
failwith "TODO: compile discriminant read for something that no longer has a discriminant"
in
(object (_self)
inherit [_] map as super
method! visit_expr (((), _) as env) e =
match e with
| [%cremepat {| Eurydice::discriminant, ?u>(?e) |}] -> (
match lookup_tag_lid (H.assert_tlid e.typ) with
| `Direct -> with_type u (ECast (e, u))
| `TagField tag_lid ->
with_type u (ECast (with_type (TQualified tag_lid) (EField (e, "tag")), u)))
| _ -> super#visit_expr env e
end)
#visit_files
() files
================================================
FILE: lib/Cleanup3.ml
================================================
(* Administrative cleanups that do not get checked. *)
(* CG-polymorphic external signatures generally cannot be implemented with C functions, and Eurydice
expects those to be hand-written using macros. There is one exception, though:
- all of the const generics appear in positions that would anyhow decay to pointers (e.g.,
void f(int x[N]) can be replaced by void f(int *x) -- it's the same in C)
- the return type is unit -- the implementation doesn't need to receive the return type as an
argument
*)
module B = Builtin
open Krml
open Ast
let decay_cg_externals =
object (self)
inherit [_] Krml.Ast.map as super
(* Since we allocate new names, we reuse the C name allocation facility *)
inherit Simplify.scope_helpers
method! visit_file env f =
current_file <- fst f;
super#visit_file env f
method! visit_TCgArray (env, under_external) t n =
if under_external then
raise Exit
else
super#visit_TCgArray (env, under_external) t n
method! visit_TCgApp (env, under_external) t n =
if under_external then
raise Exit
else
super#visit_TCgApp (env, under_external) t n
method! visit_DExternal (scope_env, _) cc flags n_cgs n name t hints =
let t_ret, t_args = Helpers.flatten_arrow t in
(* MSVC throws a tantrum if it receives a zero-sized array parameter,
interpreting this as a stack allocation instead of an array type that
ought to decay to pointer. *)
let t_args =
List.map
(function
| TArray (t, (_, "0")) -> TBuf (t, false)
| t -> t)
t_args
in
if t_ret = TUnit && n_cgs > 0 then
let t_args =
List.map
(function
| TCgArray (t, _) -> TBuf (t, false)
| t -> t)
t_args
in
try
(* This throws and aborts if there are some const generics left. *)
let t_args = List.map (self#visit_typ (scope_env, true)) t_args in
(* We're good. Find the allocated C name for our declaration, and allocate a new C name for
the extra declaration *)
let c_name = Option.get (GlobalNames.lookup (fst scope_env) (name, Other)) in
let new_name = fst name, snd name ^ "_" in
self#record scope_env ~is_type:false ~is_external:true flags new_name;
let new_c_name = Option.get (GlobalNames.lookup (fst scope_env) (new_name, Other)) in
(* We build: #define <>(x0, ..., xn, _ret_t) \
<>(x0, ..., xn) *)
let prelude =
(* Names of the arguments *)
let names =
if List.length hints = List.length t_args then
hints
else
List.init (List.length t_args) (fun i -> KPrint.bsprintf "x_%d" i)
in
KPrint.bsprintf "#define %s(%s) %s(%s)" c_name
(String.concat ", " (names @ [ "_ret_t" ]))
new_c_name (String.concat ", " names)
in
DExternal
( cc,
[ Common.Prologue prelude ] @ flags,
0,
n,
new_name,
Helpers.fold_arrow t_args t_ret,
hints )
with Exit -> DExternal (cc, flags, n_cgs, n, name, Helpers.fold_arrow t_args t_ret, hints)
else
DExternal (cc, flags, n_cgs, n, name, Helpers.fold_arrow t_args t_ret, hints)
end
let build_cg_macros =
object (self)
inherit [_] Krml.Ast.reduce
method private zero = Krml.Idents.LidSet.empty
method private plus = Krml.Idents.LidSet.union
method! visit_DExternal () _ _ n_cgs n name _ _ =
if n > 0 || n_cgs > 0 then
Krml.Idents.LidSet.singleton name
else
self#zero
end
let distinguished_names =
[
(B.arr, [ TInt UInt8 ], [ CgConst (SizeT, "2") ]), ([ "Eurydice" ], "array_u8x2");
(B.arr, [ TInt UInt8 ], [ CgConst (SizeT, "4") ]), ([ "Eurydice" ], "array_u8x4");
(B.arr, [ TInt UInt8 ], [ CgConst (SizeT, "8") ]), ([ "Eurydice" ], "array_u8x8");
(B.dst_ref_shared, [ TInt UInt8; TInt SizeT ], []), ([ "Eurydice" ], "borrow_slice_u8");
(B.dst_ref_shared, [ TInt Int16; TInt SizeT ], []), ([ "Eurydice" ], "borrow_slice_i16");
(B.dst_ref_mut, [ TInt UInt8; TInt SizeT ], []), ([ "Eurydice" ], "mut_borrow_slice_u8");
(B.dst_ref_mut, [ TInt Int16; TInt SizeT ], []), ([ "Eurydice" ], "mut_borrow_slice_i16");
]
(*This identifies the decls which should be generated after monomorphism, but is already defined
in eurydice_glue.h for implementing the builtin functions. The slices are for
libcrux, specifically to be able to define the intrinsic function signatures *)
let is_builtin_lid lid =
match lid with
| [ "Prims" ], "string" (* used to pass the checker, defined in glue.h *) -> true
| _ -> List.exists (fun (_, lid') -> lid' = lid) distinguished_names
let remove_builtin_decls files =
let checker = function
| DType (lid, _, _, _, _) when is_builtin_lid lid -> None
| decl -> Some decl
in
List.map (fun (name, decls) -> name, List.filter_map checker decls) files
let also_skip_prefix_for_external_types (scope_env, _) =
let open Krml in
object (_self)
inherit [_] iter as _super
method! visit_TQualified () lid =
if GlobalNames.lookup scope_env (lid, Type) = None && GlobalNames.skip_prefix lid then
let target = GlobalNames.target_c_name ~attempt_shortening:true ~kind:Type lid in
let actual = GlobalNames.extend scope_env scope_env false (lid, Type) target in
if actual <> fst target then
KPrint.bprintf "Warning! The skip_prefix options generate name conflicts\n"
end
================================================
FILE: lib/LoadLlbc.ml
================================================
let load_file filename =
match Charon.OfJson.crate_of_json_file filename with
| Ok r -> r
| Error e ->
Printf.fprintf stderr
"Error loading JSON. This is typically due to a discrepancy between charon-ml and charon. \
See error below. (Search for \"failed on\"). \n\n\
%s"
e;
exit 1
================================================
FILE: lib/Logging.ml
================================================
module StringSet = Set.Make (String)
type logging = None | All | Some of StringSet.t
let logging = ref None
let enable_logging (modules : string) =
let modules = String.split_on_char ',' modules in
if modules = [ "*" ] then
logging := All
else
logging := Some (StringSet.of_list modules)
let has_logging m =
match !logging with
| None -> false
| All -> true
| Some s -> StringSet.mem m s
let dummy = Buffer.create 1
let log (type a) (m : string) (fmt : (a, Buffer.t, unit, unit) format4) =
if has_logging m then
Krml.KPrint.bfprintf stdout (fmt ^^ "\n")
else
Printf.ibprintf dummy fmt
================================================
FILE: lib/Options.ml
================================================
let log_level = ref ""
let config = ref ""
let comments = ref false
let fatal_errors = ref false
let keep_going = ref false
let no_const = ref false
================================================
FILE: lib/PreCleanup.ml
================================================
open Krml.Ast
module H = Krml.Helpers
(* All the transformations that need to happen in order for the program to type-check as valid Low*
*)
let expr_of_constant (w, n) = with_type (TInt w) (EConstant (w, n))
let remove_array_eq =
object
inherit Krml.DeBruijn.map_counting_cg as super
method! visit_expr (((n_cgs, n_binders) as env), _) e =
match e with
| [%cremepat {| core::array::equality::?impl::eq[#?n](#?..)(?a1, ?a2) |}] ->
let rec is_flat = function
| TCgApp (TApp (lid, [ t ]), _) -> lid = Builtin.arr && is_flat t
| TInt _ | TBool | TUnit -> true
| _ -> false
in
assert (t = u);
if is_flat t then
let diff = n_binders - n_cgs in
match impl with
| "{core::cmp::PartialEq<[U; N]> for [T; N]}" ->
with_type TBool
(EApp (Builtin.(expr_of_builtin_t ~cgs:(diff, [ n ]) array_eq [ t ]), [ a1; a2 ]))
| "{core::cmp::PartialEq<&0 ([U])> for [T; N]}" ->
let hd =
if !Options.no_const then
Builtin.array_eq_slice_mut
else
Builtin.array_eq_slice_shared
in
with_type TBool
(EApp (Builtin.(expr_of_builtin_t ~cgs:(diff, [ n ]) hd [ t ]), [ a1; a2 ]))
| _ -> failwith ("unknown array eq impl: " ^ impl)
else
failwith "TODO: non-byteeq array comparison"
| _ -> super#visit_expr (env, e.typ) e
method! visit_DFunction _ cc flags n_cgs n t lid bs e =
super#visit_DFunction (n_cgs, 0) cc flags n_cgs n t lid bs e
end
let expression_of_cg (n_cgs, n_binders) (cg : cg) =
match cg with
| CgConst n -> H.mk_sizet (int_of_string (snd n))
| CgVar var ->
let diff = n_binders - n_cgs in
with_type (TInt SizeT) (EBound (var + diff))
(* slice_to_array<&[T], [T; N], Error>(src) ->
let arr: Arr; memcpy(arr.data, src.ptr, N); Ok arr
slice_to_ref_array<&[T], &[T;N], Error, len>(src) ->
let arr: Arr; memcpy(arr.data, src.ptr); slice_to_ref_array2<&[T], &[T;N], Error, len>(src, &arr)
*)
let constness_of_slice_type t =
match t with
| TApp (lid, _) when lid = Builtin.dst_ref_shared -> true
| TApp (lid, _) when lid = Builtin.dst_ref_mut -> false
| _ -> assert false
let expand_slice_to_array =
object (_self)
inherit Krml.DeBruijn.map_counting_cg as super
method! visit_expr ((count, _) as env) e =
match e.node with
| EApp
( {
node =
ETApp
( { node = EQualified lid; _ },
_,
_,
[ _; (TCgApp (TApp (_, [ t ]), cg) as arr_t); _ ] );
_;
},
es )
when lid = Builtin.slice_to_array.name ->
let src = Krml.KList.one es in
let result_t = e.typ in
(*let arr = .. *)
let arr = with_type arr_t (EBound 0) in
let src = Krml.DeBruijn.lift 1 src in
let dst = with_type (TBuf (t, false)) (EField (arr, "data")) in
let src = with_type (TBuf (t, constness_of_slice_type src.typ)) (EField (src, "ptr")) in
let n = Krml.DeBruijn.lift 1 (expression_of_cg count cg) in
let zero = H.zero SizeT in
let memcpy = H.with_unit (EBufBlit (src, zero, dst, zero, n)) in
(* let arr = any in {memcpy (src, slice); OK (arr);} *)
with_type result_t
(ELet
( H.fresh_binder "arr" arr_t,
H.any,
with_type result_t
(ESequence [ memcpy; with_type result_t (ECons ("Ok", [ arr ])) ]) ))
| EApp
( {
node =
ETApp
( { node = EQualified lid; _ },
cgs,
_,
[
slice_t;
(TBuf ((TCgApp (TApp (_, [ t ]), cg) as arr_t), _) as arr_ref_t);
err_t;
] );
_;
},
[ slice ] )
when lid = Builtin.slice_to_ref_array.name ->
(* allocate a Arr, do memcpy and let the C macro do the choose and define the return
or error value *)
let const = constness_of_slice_type slice_t in
let slice_to_ref_array2 = Builtin.(expr_of_builtin slice_to_ref_array2) in
let ts = [ slice_t; arr_ref_t; err_t ] in
let slice_to_ref_array2 =
with_type
(Krml.DeBruijn.subst_tn ts Builtin.slice_to_ref_array2.typ)
(ETApp (slice_to_ref_array2, List.map (Krml.DeBruijn.lift 1) cgs, [], ts))
in
let arr = with_type arr_t (EBound 0) in
let arr_ref = with_type arr_ref_t (EAddrOf arr) in
let slice = Krml.DeBruijn.lift 1 slice in
let dst = with_type (TBuf (t, true)) (EField (arr, "data")) in
let src = with_type (TBuf (t, const)) (EField (slice, "ptr")) in
let n = Krml.DeBruijn.lift 1 (expression_of_cg count cg) in
(* let n = with_type (TInt SizeT) (EField (slice, "meta")) in *)
let zero = H.zero SizeT in
let memcpy = H.with_unit (EBufBlit (src, zero, dst, zero, n)) in
with_type e.typ
(ELet
( H.fresh_binder "arr" arr_t,
H.any,
with_type e.typ
(ESequence
[ memcpy; with_type e.typ (EApp (slice_to_ref_array2, [ slice; arr_ref ])) ])
))
| _ -> super#visit_expr env e
method! visit_DFunction _ cc flags n_cgs n t name bs e =
super#visit_DFunction (n_cgs, 0) cc flags n_cgs n t name bs e
end
(** Comes from [drop_unused] in Inlining.ml, we use it to remove the builtin function defined using
abstract syntax when they are not used. Otherwise they will refer to the undefined Range type
and fail the check *)
let builtin_func_lids = List.map lid_of_decl Builtin.builtin_defined_funcs
let drop_unused_builtin files =
let open Krml in
let open Krml.Common in
let seen = Hashtbl.create 41 in
let body_of_lid = Helpers.build_map files (fun map d -> Hashtbl.add map (lid_of_decl d) d) in
let visitor =
object (self)
inherit [_] iter as super
method! visit_EQualified (before, _) lid = self#discover before lid
method! visit_TQualified before lid = self#discover before lid
method! visit_TApp before lid ts =
self#discover before lid;
List.iter (self#visit_typ before) ts
method private discover before lid =
if not (Hashtbl.mem seen lid) then begin
Hashtbl.add seen lid ();
if Hashtbl.mem body_of_lid lid then
ignore (super#visit_decl (lid :: before) (Hashtbl.find body_of_lid lid))
end
method! visit_decl _ d =
let flags = flags_of_decl d in
let lid = lid_of_decl d in
if (not (List.exists (( = ) Private) flags)) && not (Drop.lid lid) then begin
Hashtbl.add seen lid ();
super#visit_decl [ lid ] d
end
end
in
visitor#visit_files [] files;
Hashtbl.add seen ([ "LowStar"; "Ignore" ], "ignore") ();
filter_decls
(fun d ->
let flags = flags_of_decl d in
let lid = lid_of_decl d in
if
(List.exists (( = ) Private) flags || Drop.lid lid)
&& (not (Hashtbl.mem seen lid))
&& List.mem lid builtin_func_lids
then
None
else
Some d)
files
let precleanup files =
let files = remove_array_eq#visit_files (0, 0) files in
let files = drop_unused_builtin files in
let files = expand_slice_to_array#visit_files (0, 0) files in
files
let merge files =
let open Krml.Idents in
let open Krml.PrintAst.Ops in
let merge_decl lid d1 d2 =
match d1, d2 with
| _ when Krml.Idents.LidSet.mem lid Builtin.skip -> None
| Some d1, None | None, Some d1 -> Some d1
| None, None -> assert false
| Some d1, Some d2 -> (
let is_external = function
| DExternal _ -> true
| _ -> false
in
let check_equal () =
if d1 <> d2 then begin
Krml.KPrint.bprintf "%a is:\n%a\n\nVS\n\n%a\n" plid lid pdecl d1 pdecl d2;
failwith "can't reconcile these two definitions"
end
in
match d1, d2 with
| DExternal _, d2 | d2, DExternal _ ->
if is_external d2 then
check_equal ();
Some d2
| _ ->
check_equal ();
Some d1)
in
let decl_map decls = LidMap.of_seq (List.to_seq (List.map (fun d -> lid_of_decl d, d) decls)) in
let merge_decls decls1 decls2 = LidMap.merge merge_decl decls1 decls2 in
let concat_filenames f1 f2 =
if f1 = "" then
f2
else
f1 ^ "_" ^ f2
in
let merge_files (f1, decls1) (f2, decls2) =
concat_filenames f1 f2, merge_decls decls1 (decl_map decls2)
in
let f, decls = List.fold_left merge_files ("", LidMap.empty) files in
let decls = List.map snd (List.of_seq (LidMap.to_seq decls)) in
let decls = Bundles.topological_sort decls in
f, decls
================================================
FILE: lib/Utf8.ml
================================================
let ascii_of_utf8_str (str : string) =
let get_uchar_list (str : string) =
let rec get_uchar_list acc idx =
try
let uchar = Uchar.utf_decode_uchar (String.get_utf_8_uchar str idx) in
let char_len = Uchar.utf_8_byte_length uchar in
get_uchar_list (uchar :: acc) (idx + char_len)
with Invalid_argument _ -> List.rev acc
in
get_uchar_list [] 0
in
let uchar_list_to_ascii lst =
let to_str uchar =
if Uchar.is_char uchar then
Uchar.to_char uchar |> Char.escaped
else
Printf.sprintf "\\u{%x}" @@ Uchar.to_int uchar
in
List.map to_str lst |> String.concat ""
in
get_uchar_list str |> uchar_list_to_ascii
================================================
FILE: lib/dune
================================================
(library
(name eurydice)
(libraries charon krml yaml)
(preprocess
(pps ppx_deriving.std cremepat)))
(env
(_
(flags
(:standard -w @1-2@3-7@8..12@14..21@23..29-30@31..38-39-40-41@43@57))))
================================================
FILE: out/test-array/array.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "array.h"
/**
A monomorphic instance of Eurydice.array_to_subslice_shared
with types uint8_t, core_ops_range_Range size_t, Eurydice_derefed_slice uint8_t
with const generics
- N= 32
*/
static Eurydice_borrow_slice_u8
array_to_subslice_shared_d4(const Eurydice_arr_ec *a, core_ops_range_Range_87 r)
{
return
(KRML_CLITERAL(Eurydice_borrow_slice_u8){ .ptr = a->data + r.start, .meta = r.end - r.start });
}
uint8_t array_fun(Eurydice_dst_ref_shared_60 x)
{
return
array_to_subslice_shared_d4(&x.ptr[0U],
(KRML_CLITERAL(core_ops_range_Range_87){ .start = (size_t)0U, .end = (size_t)1U })).ptr[0U];
}
Eurydice_arr_ec array_init(void)
{
return (KRML_CLITERAL(Eurydice_arr_ec){ .data = { 0U } });
}
array_Foo array_mk_foo(void)
{
Eurydice_arr_a0 x = { .data = { 0U } };
Eurydice_arr_a0 y;
uint32_t repeat_expression[2U];
for (uint32_t _i = 0U; _i < (size_t)2U; ++_i)
repeat_expression[_i] = 1U;
memcpy(y.data, repeat_expression, (size_t)2U * sizeof (uint32_t));
return (KRML_CLITERAL(array_Foo){ .x = x, .y = y });
}
array_Foo array_mk_foo2(void)
{
return array_mk_foo();
}
void array_mut_array(Eurydice_arr_a0 x)
{
x.data[0U] = 1U;
}
void array_mut_foo(array_Foo f)
{
f.x.data[0U] = 1U;
Eurydice_arr_a0 copy = f.y;
copy.data[0U] = 0U;
EURYDICE_ASSERT(copy.data[0U] != 1U, "panic!");
}
/**
This function found in impl {core::ops::function::FnMut<(usize), u32> for array::mk_incr::closure}
*/
/**
A monomorphic instance of array.mk_incr.call_mut_e2
with const generics
- K= 10
*/
uint32_t array_mk_incr_call_mut_e2_55(void **_, size_t tupled_args)
{
size_t i = tupled_args;
return (uint32_t)i;
}
/**
This function found in impl {core::ops::function::FnOnce<(usize), u32> for array::mk_incr::closure}
*/
/**
A monomorphic instance of array.mk_incr.call_once_b7
with const generics
- K= 10
*/
uint32_t array_mk_incr_call_once_b7_55(size_t _)
{
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
return array_mk_incr_call_mut_e2_55(&lvalue, _);
}
/**
A monomorphic instance of array.mk_incr
with const generics
- K= 10
*/
Eurydice_arr_6c array_mk_incr_55(void)
{
Eurydice_arr_6c arr_struct;
KRML_MAYBE_FOR10(i,
(size_t)0U,
(size_t)10U,
(size_t)1U,
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
arr_struct.data[i] = array_mk_incr_call_mut_e2_55(&lvalue, i););
return arr_struct;
}
/**
This function found in impl {core::ops::function::FnMut<(usize), u32> for array::mk_incr2::closure<0, K>}
*/
/**
A monomorphic instance of array.mk_incr2.call_mut_eb
with const generics
- K= 10
*/
uint32_t array_mk_incr2_call_mut_eb_55(const uint32_t **_, size_t tupled_args)
{
size_t i = tupled_args;
return (uint32_t)i + _[0U][0U];
}
/**
This function found in impl {core::ops::function::FnOnce<(usize), u32> for array::mk_incr2::closure<0, K>}
*/
/**
A monomorphic instance of array.mk_incr2.call_once_ad
with const generics
- K= 10
*/
uint32_t array_mk_incr2_call_once_ad_55(const uint32_t *_, size_t _0)
{
return array_mk_incr2_call_mut_eb_55(&_, _0);
}
/**
A monomorphic instance of array.mk_incr2
with const generics
- K= 10
*/
Eurydice_arr_6c array_mk_incr2_55(void)
{
uint32_t j = 1U;
Eurydice_arr_6c arr_struct;
KRML_MAYBE_FOR10(i,
(size_t)0U,
(size_t)10U,
(size_t)1U,
/* original Rust expression is not an lvalue in C */
const uint32_t *lvalue = &j;
arr_struct.data[i] = array_mk_incr2_call_mut_eb_55(&lvalue, i););
return arr_struct;
}
/**
This function found in impl {core::ops::function::FnMut<(u32), u16> for array::plus_one::closure}
*/
/**
A monomorphic instance of array.plus_one.call_mut_8d
with const generics
- K= 1
*/
uint16_t array_plus_one_call_mut_8d_6c(void **_, uint32_t tupled_args)
{
uint32_t x = tupled_args;
return (uint16_t)(x + 1U);
}
/**
This function found in impl {core::ops::function::FnOnce<(u32), u16> for array::plus_one::closure}
*/
/**
A monomorphic instance of array.plus_one.call_once_36
with const generics
- K= 1
*/
uint16_t array_plus_one_call_once_36_6c(uint32_t _)
{
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
return array_plus_one_call_mut_8d_6c(&lvalue, _);
}
/**
A monomorphic instance of array.plus_one
with const generics
- K= 1
*/
Eurydice_arr_96 array_plus_one_6c(Eurydice_arr_d5 x)
{
Eurydice_arr_96 arr_mapped_str;
{
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
arr_mapped_str.data[0U] = array_plus_one_call_mut_8d_6c(&lvalue, x.data[0U]);
}
return arr_mapped_str;
}
/**
This function found in impl {core::ops::function::FnMut<(usize), usize> for array::nested_from_fn::closure::closure<0, K>}
*/
/**
A monomorphic instance of array.nested_from_fn.closure.call_mut_74
with const generics
- K= 4
*/
size_t array_nested_from_fn_closure_call_mut_74_23(const size_t **_, size_t tupled_args)
{
size_t i = tupled_args;
return i + _[0U][0U];
}
/**
This function found in impl {core::ops::function::FnOnce<(usize), usize> for array::nested_from_fn::closure::closure<0, K>}
*/
/**
A monomorphic instance of array.nested_from_fn.closure.call_once_4d
with const generics
- K= 4
*/
size_t array_nested_from_fn_closure_call_once_4d_23(const size_t *_, size_t _0)
{
return array_nested_from_fn_closure_call_mut_74_23(&_, _0);
}
/**
This function found in impl {core::ops::function::FnMut<(usize), [usize; K]> for array::nested_from_fn::closure}
*/
/**
A monomorphic instance of array.nested_from_fn.call_mut_6c
with const generics
- K= 4
*/
Eurydice_arr_cc array_nested_from_fn_call_mut_6c_23(void **_, size_t tupled_args)
{
size_t j = tupled_args;
Eurydice_arr_cc arr_struct;
KRML_MAYBE_FOR4(i,
(size_t)0U,
(size_t)4U,
(size_t)1U,
/* original Rust expression is not an lvalue in C */
const size_t *lvalue = &j;
arr_struct.data[i] = array_nested_from_fn_closure_call_mut_74_23(&lvalue, i););
return arr_struct;
}
/**
This function found in impl {core::ops::function::FnOnce<(usize), [usize; K]> for array::nested_from_fn::closure}
*/
/**
A monomorphic instance of array.nested_from_fn.call_once_d9
with const generics
- K= 4
*/
Eurydice_arr_cc array_nested_from_fn_call_once_d9_23(size_t _)
{
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
return array_nested_from_fn_call_mut_6c_23(&lvalue, _);
}
/**
A monomorphic instance of array.nested_from_fn
with const generics
- K= 4
*/
Eurydice_arr_89 array_nested_from_fn_23(void)
{
Eurydice_arr_89 arr_struct;
KRML_MAYBE_FOR4(i,
(size_t)0U,
(size_t)4U,
(size_t)1U,
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
arr_struct.data[i] = array_nested_from_fn_call_mut_6c_23(&lvalue, i););
return arr_struct;
}
/**
A monomorphic instance of array.const_eq
with const generics
- K= 2
*/
bool array_const_eq_af(Eurydice_arr_a0 x, Eurydice_arr_a0 y)
{
return Eurydice_array_eq((size_t)2U, &x, &y, uint32_t);
}
typedef struct const_uint32_t__x2_s
{
const uint32_t *fst;
const uint32_t *snd;
}
const_uint32_t__x2;
typedef struct const_uint16_t__x2_s
{
const uint16_t *fst;
const uint16_t *snd;
}
const_uint16_t__x2;
typedef struct const_size_t__x2_s
{
const size_t *fst;
const size_t *snd;
}
const_size_t__x2;
typedef struct const_bool__x2_s
{
const bool *fst;
const bool *snd;
}
const_bool__x2;
void array_main(void)
{
/* XXX1 */
array_Foo uu____0 = array_mk_foo2();
Eurydice_arr_a0 x = uu____0.x;
Eurydice_arr_a0 y = uu____0.y;
uint32_t unsigned0 = 0U;
array_mut_array(x);
/* XXX2 */
array_mut_foo((KRML_CLITERAL(array_Foo){ .x = x, .y = y }));
/* XXX3
XXX4 */
const_uint32_t__x2 uu____1 = { .fst = x.data, .snd = &unsigned0 };
EURYDICE_ASSERT(uu____1.fst[0U] == uu____1.snd[0U], "panic!");
Eurydice_arr_6c a = array_mk_incr_55();
/* original Rust expression is not an lvalue in C */
uint32_t lvalue0 = 9U;
const_uint32_t__x2 uu____2 = { .fst = &a.data[9U], .snd = &lvalue0 };
EURYDICE_ASSERT(uu____2.fst[0U] == uu____2.snd[0U], "panic!");
Eurydice_arr_6c a0 = array_mk_incr2_55();
uint32_t expected = 10U;
const_uint32_t__x2 uu____3 = { .fst = &a0.data[9U], .snd = &expected };
EURYDICE_ASSERT(uu____3.fst[0U] == uu____3.snd[0U], "panic!");
Eurydice_arr_96 a1 = array_plus_one_6c((KRML_CLITERAL(Eurydice_arr_d5){ .data = { 0U } }));
/* original Rust expression is not an lvalue in C */
uint16_t lvalue1 = 1U;
const_uint16_t__x2 uu____4 = { .fst = a1.data, .snd = &lvalue1 };
EURYDICE_ASSERT(uu____4.fst[0U] == uu____4.snd[0U], "panic!");
/* XXX5 */
Eurydice_arr_89 a2 = array_nested_from_fn_23();
/* original Rust expression is not an lvalue in C */
size_t lvalue2 = (size_t)6U;
const_size_t__x2 uu____5 = { .fst = &a2.data[3U].data[3U], .snd = &lvalue2 };
EURYDICE_ASSERT(uu____5.fst[0U] == uu____5.snd[0U], "panic!");
/* XXX6 */
Eurydice_arr_a0 x0;
uint32_t repeat_expression0[2U];
for (uint32_t _i = 0U; _i < (size_t)2U; ++_i)
repeat_expression0[_i] = 2U;
memcpy(x0.data, repeat_expression0, (size_t)2U * sizeof (uint32_t));
Eurydice_arr_a0 y0;
uint32_t repeat_expression[2U];
for (uint32_t _i = 0U; _i < (size_t)2U; ++_i)
repeat_expression[_i] = 2U;
memcpy(y0.data, repeat_expression, (size_t)2U * sizeof (uint32_t));
bool b = array_const_eq_af(x0, y0);
/* original Rust expression is not an lvalue in C */
bool lvalue = true;
const_bool__x2 uu____6 = { .fst = &b, .snd = &lvalue };
EURYDICE_ASSERT(uu____6.fst[0U] == uu____6.snd[0U], "panic!");
}
void array_references(void)
{
array_init();
}
================================================
FILE: out/test-array/array.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef array_H
#define array_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $2size_t
*/
typedef struct Eurydice_arr_a0_s { uint32_t data[2U]; } Eurydice_arr_a0;
typedef struct array_Foo_s
{
Eurydice_arr_a0 x;
Eurydice_arr_a0 y;
}
array_Foo;
extern bool
core_cmp_impls__core__cmp__PartialEq_u32__for_u32__eq(const uint32_t *x0, const uint32_t *x1);
/**
A monomorphic instance of Eurydice.arr
with types uint8_t
with const generics
- $32size_t
*/
typedef struct Eurydice_arr_ec_s { uint8_t data[32U]; } Eurydice_arr_ec;
/**
A monomorphic instance of core.ops.range.Range
with types size_t
*/
typedef struct core_ops_range_Range_87_s
{
size_t start;
size_t end;
}
core_ops_range_Range_87;
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types Eurydice_arr_ec, size_t
*/
typedef struct Eurydice_dst_ref_shared_60_s
{
const Eurydice_arr_ec *ptr;
size_t meta;
}
Eurydice_dst_ref_shared_60;
uint8_t array_fun(Eurydice_dst_ref_shared_60 x);
Eurydice_arr_ec array_init(void);
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
array_Foo array_mk_foo(void);
array_Foo array_mk_foo2(void);
void array_mut_array(Eurydice_arr_a0 x);
void array_mut_foo(array_Foo f);
/**
This function found in impl {core::ops::function::FnMut<(usize), u32> for array::mk_incr::closure}
*/
/**
A monomorphic instance of array.mk_incr.call_mut_e2
with const generics
- K= 10
*/
uint32_t array_mk_incr_call_mut_e2_55(void **_, size_t tupled_args);
/**
This function found in impl {core::ops::function::FnOnce<(usize), u32> for array::mk_incr::closure}
*/
/**
A monomorphic instance of array.mk_incr.call_once_b7
with const generics
- K= 10
*/
uint32_t array_mk_incr_call_once_b7_55(size_t _);
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $10size_t
*/
typedef struct Eurydice_arr_6c_s { uint32_t data[10U]; } Eurydice_arr_6c;
/**
A monomorphic instance of array.mk_incr
with const generics
- K= 10
*/
Eurydice_arr_6c array_mk_incr_55(void);
/**
A monomorphic instance of array.mk_incr2.closure
with const generics
- $10size_t
*/
typedef const uint32_t *array_mk_incr2_closure_e4;
/**
This function found in impl {core::ops::function::FnMut<(usize), u32> for array::mk_incr2::closure<0, K>}
*/
/**
A monomorphic instance of array.mk_incr2.call_mut_eb
with const generics
- K= 10
*/
uint32_t array_mk_incr2_call_mut_eb_55(const uint32_t **_, size_t tupled_args);
/**
This function found in impl {core::ops::function::FnOnce<(usize), u32> for array::mk_incr2::closure<0, K>}
*/
/**
A monomorphic instance of array.mk_incr2.call_once_ad
with const generics
- K= 10
*/
uint32_t array_mk_incr2_call_once_ad_55(const uint32_t *_, size_t _0);
/**
A monomorphic instance of array.mk_incr2
with const generics
- K= 10
*/
Eurydice_arr_6c array_mk_incr2_55(void);
/**
This function found in impl {core::ops::function::FnMut<(u32), u16> for array::plus_one::closure}
*/
/**
A monomorphic instance of array.plus_one.call_mut_8d
with const generics
- K= 1
*/
uint16_t array_plus_one_call_mut_8d_6c(void **_, uint32_t tupled_args);
/**
This function found in impl {core::ops::function::FnOnce<(u32), u16> for array::plus_one::closure}
*/
/**
A monomorphic instance of array.plus_one.call_once_36
with const generics
- K= 1
*/
uint16_t array_plus_one_call_once_36_6c(uint32_t _);
/**
A monomorphic instance of Eurydice.arr
with types uint16_t
with const generics
- $1size_t
*/
typedef struct Eurydice_arr_96_s { uint16_t data[1U]; } Eurydice_arr_96;
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $1size_t
*/
typedef struct Eurydice_arr_d5_s { uint32_t data[1U]; } Eurydice_arr_d5;
/**
A monomorphic instance of array.plus_one
with const generics
- K= 1
*/
Eurydice_arr_96 array_plus_one_6c(Eurydice_arr_d5 x);
/**
A monomorphic instance of array.nested_from_fn.closure.closure
with const generics
- $4size_t
*/
typedef const size_t *array_nested_from_fn_closure_closure_34;
/**
This function found in impl {core::ops::function::FnMut<(usize), usize> for array::nested_from_fn::closure::closure<0, K>}
*/
/**
A monomorphic instance of array.nested_from_fn.closure.call_mut_74
with const generics
- K= 4
*/
size_t array_nested_from_fn_closure_call_mut_74_23(const size_t **_, size_t tupled_args);
/**
This function found in impl {core::ops::function::FnOnce<(usize), usize> for array::nested_from_fn::closure::closure<0, K>}
*/
/**
A monomorphic instance of array.nested_from_fn.closure.call_once_4d
with const generics
- K= 4
*/
size_t array_nested_from_fn_closure_call_once_4d_23(const size_t *_, size_t _0);
/**
A monomorphic instance of Eurydice.arr
with types size_t
with const generics
- $4size_t
*/
typedef struct Eurydice_arr_cc_s { size_t data[4U]; } Eurydice_arr_cc;
/**
This function found in impl {core::ops::function::FnMut<(usize), [usize; K]> for array::nested_from_fn::closure}
*/
/**
A monomorphic instance of array.nested_from_fn.call_mut_6c
with const generics
- K= 4
*/
Eurydice_arr_cc array_nested_from_fn_call_mut_6c_23(void **_, size_t tupled_args);
/**
This function found in impl {core::ops::function::FnOnce<(usize), [usize; K]> for array::nested_from_fn::closure}
*/
/**
A monomorphic instance of array.nested_from_fn.call_once_d9
with const generics
- K= 4
*/
Eurydice_arr_cc array_nested_from_fn_call_once_d9_23(size_t _);
/**
A monomorphic instance of Eurydice.arr
with types Eurydice_arr_cc
with const generics
- $4size_t
*/
typedef struct Eurydice_arr_89_s { Eurydice_arr_cc data[4U]; } Eurydice_arr_89;
/**
A monomorphic instance of array.nested_from_fn
with const generics
- K= 4
*/
Eurydice_arr_89 array_nested_from_fn_23(void);
/**
A monomorphic instance of array.const_eq
with const generics
- K= 2
*/
bool array_const_eq_af(Eurydice_arr_a0 x, Eurydice_arr_a0 y);
void array_main(void);
void array_references(void);
#define array_mk_incr_closure__core__marker__Destruct_for_array__mk_incr__closure_K___drop_in_place(x_0, x_1, _ret_t) array_mk_incr_closure__core__marker__Destruct_for_array__mk_incr__closure_K___drop_in_place_(x_0, x_1)
extern void
array_mk_incr_closure__core__marker__Destruct_for_array__mk_incr__closure_K___drop_in_place_(
size_t x0,
void **x1
);
#define array_nested_from_fn_closure__core__marker__Destruct_for_array__nested_from_fn__closure_K___drop_in_place(x_0, x_1, _ret_t) array_nested_from_fn_closure__core__marker__Destruct_for_array__nested_from_fn__closure_K___drop_in_place_(x_0, x_1)
extern void
array_nested_from_fn_closure__core__marker__Destruct_for_array__nested_from_fn__closure_K___drop_in_place_(
size_t x0,
void **x1
);
#define array_plus_one_closure__core__marker__Destruct_for_array__plus_one__closure_K___drop_in_place(x_0, x_1, _ret_t) array_plus_one_closure__core__marker__Destruct_for_array__plus_one__closure_K___drop_in_place_(x_0, x_1)
extern void
array_plus_one_closure__core__marker__Destruct_for_array__plus_one__closure_K___drop_in_place_(
size_t x0,
void **x1
);
#if defined(__cplusplus)
}
#endif
#define array_H_DEFINED
#endif /* array_H */
================================================
FILE: out/test-array2d/array2d.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "array2d.h"
bool array2d_f(Eurydice_arr_ac x)
{
x.data[0U] = (KRML_CLITERAL(Eurydice_arr_a0){ .data = { 1U, 2U } });
Eurydice_arr_ac
y =
{
.data = {
{ .data = { 1U, 2U } },
{ .data = { 3U, 4U } },
{ .data = { 1U, 2U } },
{ .data = { 3U, 4U } }
}
};
return Eurydice_array_eq((size_t)4U, &x, &y, Eurydice_arr_a0);
}
typedef struct const_bool__x2_s
{
const bool *fst;
const bool *snd;
}
const_bool__x2;
void array2d_main(void)
{
Eurydice_arr_ac y;
Eurydice_arr_a0 repeat_expression[4U];
KRML_MAYBE_FOR4(i,
(size_t)0U,
(size_t)4U,
(size_t)1U,
repeat_expression[i] = (KRML_CLITERAL(Eurydice_arr_a0){ .data = { 1U, 2U } }););
memcpy(y.data, repeat_expression, (size_t)4U * sizeof (Eurydice_arr_a0));
y.data[1U] = (KRML_CLITERAL(Eurydice_arr_a0){ .data = { 3U, 4U } });
y.data[3U] = (KRML_CLITERAL(Eurydice_arr_a0){ .data = { 3U, 4U } });
bool actual = array2d_f(y);
bool expected = true;
const_bool__x2 uu____0 = { .fst = &actual, .snd = &expected };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
================================================
FILE: out/test-array2d/array2d.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef array2d_H
#define array2d_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
extern bool
core_cmp_impls__core__cmp__PartialEq_u32__for_u32__eq(const uint32_t *x0, const uint32_t *x1);
extern bool
core_cmp_impls__core__cmp__PartialEq_u32__for_u32__ne(const uint32_t *x0, const uint32_t *x1);
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $2size_t
*/
typedef struct Eurydice_arr_a0_s { uint32_t data[2U]; } Eurydice_arr_a0;
/**
A monomorphic instance of Eurydice.arr
with types Eurydice_arr_a0
with const generics
- $4size_t
*/
typedef struct Eurydice_arr_ac_s { Eurydice_arr_a0 data[4U]; } Eurydice_arr_ac;
bool array2d_f(Eurydice_arr_ac x);
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
void array2d_main(void);
#if defined(__cplusplus)
}
#endif
#define array2d_H_DEFINED
#endif /* array2d_H */
================================================
FILE: out/test-castunsize/castunsize.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "castunsize.h"
typedef struct const_uint32_t__x2_s
{
const uint32_t *fst;
const uint32_t *snd;
}
const_uint32_t__x2;
void castunsize_main1(void)
{
castunsize_S_e9 x = { .foo = 0U, .my_data = { .data = { 0U } } };
Eurydice_dst_ref_shared_8b x0 = { .ptr = (const castunsize_T *)&x, .meta = (size_t)4U };
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2
uu____0 = { .fst = &((const uint32_t *)x0.ptr->my_data)[3U], .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
/**
A monomorphic instance of Eurydice.array_to_slice_mut
with types uint32_t
with const generics
- N= 4
*/
static Eurydice_dst_ref_mut_0c array_to_slice_mut_32(Eurydice_arr_e5 *a)
{
Eurydice_dst_ref_mut_0c lit;
lit.ptr = a->data;
lit.meta = (size_t)4U;
return lit;
}
void castunsize_main3(void)
{
Eurydice_dst_ref_mut_0c
x =
array_to_slice_mut_32(Eurydice_box_new((KRML_CLITERAL(Eurydice_arr_e5){ .data = { 0U } }),
Eurydice_arr_e5,
Eurydice_arr_e5 *));
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2 uu____0 = { .fst = &x.ptr[3U], .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
/**
A monomorphic instance of castunsize.main2
with const generics
- K= 5
*/
void castunsize_main2_a5(void)
{
castunsize_S_b9 x = { .foo = 0U, .my_data = { .data = { 0U } } };
Eurydice_dst_ref_shared_8b x0 = { .ptr = (const castunsize_T *)&x, .meta = (size_t)5U };
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2
uu____0 = { .fst = &((const uint32_t *)x0.ptr->my_data)[3U], .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
/**
A monomorphic instance of Eurydice.array_to_slice_mut
with types uint32_t
with const generics
- N= 5
*/
static Eurydice_dst_ref_mut_0c array_to_slice_mut_d0(Eurydice_arr_fb *a)
{
Eurydice_dst_ref_mut_0c lit;
lit.ptr = a->data;
lit.meta = (size_t)5U;
return lit;
}
/**
A monomorphic instance of castunsize.main4
with const generics
- K= 5
*/
void castunsize_main4_a5(void)
{
Eurydice_dst_ref_mut_0c
x =
array_to_slice_mut_d0(Eurydice_box_new((KRML_CLITERAL(Eurydice_arr_fb){ .data = { 0U } }),
Eurydice_arr_fb,
Eurydice_arr_fb *));
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2 uu____0 = { .fst = &x.ptr[3U], .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
void castunsize_main(void)
{
castunsize_main1();
castunsize_main2_a5();
castunsize_main3();
castunsize_main4_a5();
}
================================================
FILE: out/test-castunsize/castunsize.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef castunsize_H
#define castunsize_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
typedef struct castunsize_T_s
{
uint32_t foo;
uint32_t my_data[];
}
castunsize_T;
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $4size_t
*/
typedef struct Eurydice_arr_e5_s { uint32_t data[4U]; } Eurydice_arr_e5;
/**
A monomorphic instance of castunsize.S
with types Eurydice_arr_e5
*/
typedef struct castunsize_S_e9_s
{
uint32_t foo;
Eurydice_arr_e5 my_data;
}
castunsize_S_e9;
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types castunsize_T, size_t
*/
typedef struct Eurydice_dst_ref_shared_8b_s
{
const castunsize_T *ptr;
size_t meta;
}
Eurydice_dst_ref_shared_8b;
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types uint32_t, size_t
*/
typedef struct Eurydice_dst_ref_shared_0c_s
{
const uint32_t *ptr;
size_t meta;
}
Eurydice_dst_ref_shared_0c;
void castunsize_main1(void);
/**
A monomorphic instance of Eurydice.dst_ref_mut
with types uint32_t, size_t
*/
typedef struct Eurydice_dst_ref_mut_0c_s
{
uint32_t *ptr;
size_t meta;
}
Eurydice_dst_ref_mut_0c;
void castunsize_main3(void);
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $5size_t
*/
typedef struct Eurydice_arr_fb_s { uint32_t data[5U]; } Eurydice_arr_fb;
/**
A monomorphic instance of castunsize.S
with types Eurydice_arr_fb
*/
typedef struct castunsize_S_b9_s
{
uint32_t foo;
Eurydice_arr_fb my_data;
}
castunsize_S_b9;
/**
A monomorphic instance of castunsize.main2
with const generics
- K= 5
*/
void castunsize_main2_a5(void);
/**
A monomorphic instance of castunsize.main4
with const generics
- K= 5
*/
void castunsize_main4_a5(void);
void castunsize_main(void);
#if defined(__cplusplus)
}
#endif
#define castunsize_H_DEFINED
#endif /* castunsize_H */
================================================
FILE: out/test-closure/closure.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "closure.h"
/**
This function found in impl {core::ops::function::FnMut<(usize), usize> for closure::f::closure::closure<0, 1>}
*/
size_t closure_f_closure_call_mut_8a(closure_f_closure_closure *_, size_t tupled_args)
{
size_t j = tupled_args;
return _->fst->data[0U] + _->snd[0U] + j;
}
/**
This function found in impl {core::ops::function::FnOnce<(usize), usize> for closure::f::closure::closure<0, 1>}
*/
size_t closure_f_closure_call_once_b7(closure_f_closure_closure _, size_t _0)
{
return closure_f_closure_call_mut_8a(&_, _0);
}
/**
This function found in impl {core::ops::function::FnMut<(usize), [usize; 1usize]> for closure::f::closure<0>}
*/
Eurydice_arr_58 closure_f_call_mut_82(const Eurydice_arr_58 **_, size_t tupled_args)
{
size_t i0 = tupled_args;
Eurydice_arr_58 arr_struct;
{
/* original Rust expression is not an lvalue in C */
closure_f_closure_closure lvalue = { .fst = _[0U], .snd = &i0 };
arr_struct.data[0U] = closure_f_closure_call_mut_8a(&lvalue, (size_t)0U);
}
return arr_struct;
}
/**
This function found in impl {core::ops::function::FnOnce<(usize), [usize; 1usize]> for closure::f::closure<0>}
*/
Eurydice_arr_58 closure_f_call_once_86(const Eurydice_arr_58 *_, size_t _0)
{
return closure_f_call_mut_82(&_, _0);
}
Eurydice_arr_2d closure_f(void)
{
Eurydice_arr_58 s = { .data = { 0U } };
Eurydice_arr_2d arr_struct;
{
/* original Rust expression is not an lvalue in C */
const Eurydice_arr_58 *lvalue = &s;
arr_struct.data[0U] = closure_f_call_mut_82(&lvalue, (size_t)0U);
}
Eurydice_arr_2d a = arr_struct;
return a;
}
typedef struct const_size_t__x2_s
{
const size_t *fst;
const size_t *snd;
}
const_size_t__x2;
void closure_main(void)
{
/* original Rust expression is not an lvalue in C */
Eurydice_arr_2d lvalue = closure_f();
size_t actual = lvalue.data->data[0U];
size_t expected = (size_t)0U;
const_size_t__x2 uu____0 = { .fst = &actual, .snd = &expected };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
================================================
FILE: out/test-closure/closure.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef closure_H
#define closure_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
typedef struct Eurydice_arr_58_s Eurydice_arr_58;
typedef const Eurydice_arr_58 *closure_f_closure;
typedef struct closure_f_closure_closure_s
{
const Eurydice_arr_58 *fst;
const size_t *snd;
}
closure_f_closure_closure;
/**
A monomorphic instance of Eurydice.arr
with types size_t
with const generics
- $1size_t
*/
typedef struct Eurydice_arr_58_s { size_t data[1U]; } Eurydice_arr_58;
/**
This function found in impl {core::ops::function::FnMut<(usize), usize> for closure::f::closure::closure<0, 1>}
*/
size_t closure_f_closure_call_mut_8a(closure_f_closure_closure *_, size_t tupled_args);
/**
This function found in impl {core::ops::function::FnOnce<(usize), usize> for closure::f::closure::closure<0, 1>}
*/
size_t closure_f_closure_call_once_b7(closure_f_closure_closure _, size_t _0);
/**
This function found in impl {core::ops::function::FnMut<(usize), [usize; 1usize]> for closure::f::closure<0>}
*/
Eurydice_arr_58 closure_f_call_mut_82(const Eurydice_arr_58 **_, size_t tupled_args);
/**
This function found in impl {core::ops::function::FnOnce<(usize), [usize; 1usize]> for closure::f::closure<0>}
*/
Eurydice_arr_58 closure_f_call_once_86(const Eurydice_arr_58 *_, size_t _0);
/**
A monomorphic instance of Eurydice.arr
with types Eurydice_arr_58
with const generics
- $1size_t
*/
typedef struct Eurydice_arr_2d_s { Eurydice_arr_58 data[1U]; } Eurydice_arr_2d;
Eurydice_arr_2d closure_f(void);
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
void closure_main(void);
extern void
closure_f_closure_closure__core__marker__Destruct_for_closure__f__closure__closure_0__1___drop_in_place(
closure_f_closure_closure *x0
);
extern void
closure_f_closure__core__marker__Destruct_for_closure__f__closure_0___drop_in_place(
const Eurydice_arr_58 **x0
);
#if defined(__cplusplus)
}
#endif
#define closure_H_DEFINED
#endif /* closure_H */
================================================
FILE: out/test-closure_fn_cast/closure_fn_cast.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "closure_fn_cast.h"
/**
This function found in impl {core::ops::function::Fn<(i32), i32> for closure_fn_cast::main::closure}
*/
int32_t closure_fn_cast_main_call_fd(void *const *_, int32_t tupled_args)
{
int32_t x = tupled_args;
return x + 42;
}
/**
This function found in impl {core::ops::function::FnMut<(i32), i32> for closure_fn_cast::main::closure}
*/
int32_t closure_fn_cast_main_call_mut_68(void **state, int32_t args)
{
return closure_fn_cast_main_call_fd(state, args);
}
/**
This function found in impl {core::ops::function::FnOnce<(i32), i32> for closure_fn_cast::main::closure}
*/
int32_t closure_fn_cast_main_call_once_fd(int32_t _)
{
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
return closure_fn_cast_main_call_mut_68(&lvalue, _);
}
int32_t closure_fn_cast_main_closure_as_fn(int32_t arg1)
{
int32_t args = arg1;
void *state = (void *)0U;
return closure_fn_cast_main_call_once_fd(args);
}
void closure_fn_cast_main(void)
{
int32_t (*f)(int32_t x0) = closure_fn_cast_main_closure_as_fn;
KRML_HOST_IGNORE(f(1));
}
================================================
FILE: out/test-closure_fn_cast/closure_fn_cast.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef closure_fn_cast_H
#define closure_fn_cast_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
/**
This function found in impl {core::ops::function::Fn<(i32), i32> for closure_fn_cast::main::closure}
*/
int32_t closure_fn_cast_main_call_fd(void *const *_, int32_t tupled_args);
/**
This function found in impl {core::ops::function::FnMut<(i32), i32> for closure_fn_cast::main::closure}
*/
int32_t closure_fn_cast_main_call_mut_68(void **state, int32_t args);
/**
This function found in impl {core::ops::function::FnOnce<(i32), i32> for closure_fn_cast::main::closure}
*/
int32_t closure_fn_cast_main_call_once_fd(int32_t _);
int32_t closure_fn_cast_main_closure_as_fn(int32_t arg1);
void closure_fn_cast_main(void);
extern void
closure_fn_cast_main_closure__core__marker__Destruct_for_closure_fn_cast__main__closure__drop_in_place(
void **x0
);
#if defined(__cplusplus)
}
#endif
#define closure_fn_cast_H_DEFINED
#endif /* closure_fn_cast_H */
================================================
FILE: out/test-collision/collision.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "collision.h"
int32_t collision_collision(collision_Either a, collision_Direction b)
{
int32_t x;
if (a.tag == collision_Left0)
{
x = 1;
}
else
{
x = 2;
}
int32_t y;
if (b.tag == collision_Left)
{
y = 3;
}
else if (b.tag == collision_Middle)
{
y = 0;
}
else
{
y = 4;
}
return x + y;
}
void collision_main(void)
{
EURYDICE_ASSERT(collision_collision((
KRML_CLITERAL(collision_Either){ .tag = collision_Left0, .val = { .case_Left = 10 } }
),
(KRML_CLITERAL(collision_Direction){ .tag = collision_Right, .val = { .case_Right = 20ULL } }))
> 0,
"panic!");
}
================================================
FILE: out/test-collision/collision.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef collision_H
#define collision_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
#define collision_Left 0
#define collision_Middle 1
#define collision_Right 2
typedef uint8_t collision_Direction_tags;
typedef struct collision_Direction_s
{
collision_Direction_tags tag;
union {
uint64_t case_Left;
uint64_t case_Right;
}
val;
}
collision_Direction;
#define collision_Left0 0
#define collision_Right0 1
typedef uint8_t collision_Either_tags;
typedef struct collision_Either_s
{
collision_Either_tags tag;
union {
int32_t case_Left;
bool case_Right;
}
val;
}
collision_Either;
int32_t collision_collision(collision_Either a, collision_Direction b);
void collision_main(void);
#if defined(__cplusplus)
}
#endif
#define collision_H_DEFINED
#endif /* collision_H */
================================================
FILE: out/test-const_generics/const_generics.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "const_generics.h"
/**
A monomorphic instance of Eurydice.array_to_subslice_to_mut
with types uint8_t, core_ops_range_RangeTo size_t, Eurydice_derefed_slice uint8_t
with const generics
- N= 8
*/
static Eurydice_mut_borrow_slice_u8
array_to_subslice_to_mut_21(Eurydice_array_u8x8 *a, size_t r)
{
Eurydice_mut_borrow_slice_u8 lit;
lit.ptr = a->data;
lit.meta = r;
return lit;
}
/**
A monomorphic instance of Eurydice.array_to_slice_shared
with types uint8_t
with const generics
- N= 4
*/
static Eurydice_borrow_slice_u8 array_to_slice_shared_98(const Eurydice_array_u8x4 *a)
{
Eurydice_borrow_slice_u8 lit;
lit.ptr = a->data;
lit.meta = (size_t)4U;
return lit;
}
/**
A monomorphic instance of Eurydice.array_to_subslice_from_mut
with types uint8_t, core_ops_range_RangeFrom size_t, Eurydice_derefed_slice uint8_t
with const generics
- N= 8
*/
static Eurydice_mut_borrow_slice_u8
array_to_subslice_from_mut_5f(Eurydice_array_u8x8 *a, size_t r)
{
return
(KRML_CLITERAL(Eurydice_mut_borrow_slice_u8){ .ptr = a->data + r, .meta = (size_t)8U - r });
}
/**
A monomorphic instance of const_generics.serialize
with const generics
- OUT_LEN= 8
*/
Eurydice_array_u8x8 const_generics_serialize_70(Eurydice_dst_ref_shared_0c re)
{
Eurydice_array_u8x8 out = { .data = { 0U } };
Eurydice_mut_borrow_slice_u8 uu____0 = array_to_subslice_to_mut_21(&out, (size_t)4U);
/* original Rust expression is not an lvalue in C */
Eurydice_array_u8x4 lvalue0 = core_num__u32__to_be_bytes(re.ptr[0U]);
Eurydice_slice_copy(uu____0, array_to_slice_shared_98(&lvalue0), uint8_t);
Eurydice_mut_borrow_slice_u8 uu____1 = array_to_subslice_from_mut_5f(&out, (size_t)4U);
/* original Rust expression is not an lvalue in C */
Eurydice_array_u8x4 lvalue = core_num__u32__to_be_bytes(re.ptr[1U]);
Eurydice_slice_copy(uu____1, array_to_slice_shared_98(&lvalue), uint8_t);
return out;
}
/**
A monomorphic instance of Eurydice.array_to_slice_shared
with types uint32_t
with const generics
- N= 2
*/
static Eurydice_dst_ref_shared_0c array_to_slice_shared_49(const Eurydice_arr_a0 *a)
{
Eurydice_dst_ref_shared_0c lit;
lit.ptr = a->data;
lit.meta = (size_t)2U;
return lit;
}
void const_generics_main(void)
{
/* original Rust expression is not an lvalue in C */
Eurydice_arr_a0 lvalue = { .data = { 1U, 2U } };
Eurydice_array_u8x8 s = const_generics_serialize_70(array_to_slice_shared_49(&lvalue));
EURYDICE_ASSERT(s.data[3U] == 1U, "panic!");
EURYDICE_ASSERT(s.data[7U] == 2U, "panic!");
}
/**
A monomorphic instance of const_generics.mk_pairs
with types uint32_t, uint64_t
with const generics
- N= 2
- M= 4
*/
const_generics_Pair_30 const_generics_mk_pairs_67(uint32_t x, uint64_t y)
{
Eurydice_arr_a0 a1;
uint32_t repeat_expression0[2U];
KRML_MAYBE_FOR2(i, (size_t)0U, (size_t)2U, (size_t)1U, repeat_expression0[i] = x;);
memcpy(a1.data, repeat_expression0, (size_t)2U * sizeof (uint32_t));
Eurydice_arr_e4 a2;
uint64_t repeat_expression[4U];
KRML_MAYBE_FOR4(i, (size_t)0U, (size_t)4U, (size_t)1U, repeat_expression[i] = y;);
memcpy(a2.data, repeat_expression, (size_t)4U * sizeof (uint64_t));
const_generics_Pair_67 p1 = { .left = a1, .right = a2 };
const_generics_Pair_54 p2 = { .left = a2, .right = a1 };
return (KRML_CLITERAL(const_generics_Pair_30){ .left = p1.left, .right = p2.right });
}
typedef struct const_uint32_t__x2_s
{
const uint32_t *fst;
const uint32_t *snd;
}
const_uint32_t__x2;
void const_generics_main1(void)
{
const_generics_Pair_30 uu____0 = const_generics_mk_pairs_67(0U, 0ULL);
Eurydice_arr_a0 left = uu____0.left;
Eurydice_arr_a0 right = uu____0.right;
uint32_t expected = 0U;
const_uint32_t__x2 uu____1 = { .fst = left.data, .snd = &expected };
EURYDICE_ASSERT(uu____1.fst[0U] == uu____1.snd[0U], "panic!");
const_uint32_t__x2 uu____2 = { .fst = &left.data[1U], .snd = &expected };
EURYDICE_ASSERT(uu____2.fst[0U] == uu____2.snd[0U], "panic!");
const_uint32_t__x2 uu____3 = { .fst = right.data, .snd = &expected };
EURYDICE_ASSERT(uu____3.fst[0U] == uu____3.snd[0U], "panic!");
const_uint32_t__x2 uu____4 = { .fst = &right.data[1U], .snd = &expected };
EURYDICE_ASSERT(uu____4.fst[0U] == uu____4.snd[0U], "panic!");
}
/**
A monomorphic instance of const_generics.f
with const generics
- FOO= 1
- BAR= 2
*/
bool const_generics_f_06(uint32_t x, size_t y)
{
Eurydice_arr_d5 arr1;
uint32_t repeat_expression0[1U];
{
repeat_expression0[0U] = x;
}
memcpy(arr1.data, repeat_expression0, (size_t)1U * sizeof (uint32_t));
Eurydice_arr_58 arr2;
size_t repeat_expression[1U];
{
repeat_expression[0U] = y;
}
memcpy(arr2.data, repeat_expression, (size_t)1U * sizeof (size_t));
bool uu____0;
if (arr1.data[0U] == 2U)
{
uu____0 = arr2.data[0U] == (size_t)1U;
}
else
{
uu____0 = false;
}
return uu____0;
}
/**
A monomorphic instance of const_generics.f
with const generics
- FOO= 3
- BAR= 4
*/
bool const_generics_f_16(uint32_t x, size_t y)
{
Eurydice_arr_a5 arr1;
uint32_t repeat_expression0[3U];
KRML_MAYBE_FOR3(i, (size_t)0U, (size_t)3U, (size_t)1U, repeat_expression0[i] = x;);
memcpy(arr1.data, repeat_expression0, (size_t)3U * sizeof (uint32_t));
Eurydice_arr_eb arr2;
size_t repeat_expression[3U];
KRML_MAYBE_FOR3(i, (size_t)0U, (size_t)3U, (size_t)1U, repeat_expression[i] = y;);
memcpy(arr2.data, repeat_expression, (size_t)3U * sizeof (size_t));
bool uu____0;
if (arr1.data[0U] == 4U)
{
uu____0 = arr2.data[0U] == (size_t)3U;
}
else
{
uu____0 = false;
}
return uu____0;
}
/**
A monomorphic instance of const_generics.g
with const generics
- BAR= 3
- FOO= 4
*/
bool const_generics_g_16(uint32_t x, size_t y)
{
bool uu____0;
if (const_generics_f_16(x, y))
{
if (x == 4U)
{
uu____0 = y == (size_t)3U;
}
else
{
uu____0 = false;
}
}
else
{
uu____0 = false;
}
return uu____0;
}
typedef struct const_bool__x2_s
{
const bool *fst;
const bool *snd;
}
const_bool__x2;
void const_generics_main3(void)
{
bool x;
if (const_generics_f_06(0U, (size_t)0U))
{
x = const_generics_g_16(0U, (size_t)0U);
}
else
{
x = false;
}
bool expected = false;
const_bool__x2 uu____0 = { .fst = &x, .snd = &expected };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
================================================
FILE: out/test-const_generics/const_generics.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef const_generics_H
#define const_generics_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
static inline Eurydice_array_u8x4 core_num__u32__to_be_bytes(uint32_t x0);
/**
A monomorphic instance of core.ops.range.RangeTo
with types size_t
*/
typedef size_t core_ops_range_RangeTo_87;
/**
A monomorphic instance of core.ops.range.RangeFrom
with types size_t
*/
typedef size_t core_ops_range_RangeFrom_87;
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types uint32_t, size_t
*/
typedef struct Eurydice_dst_ref_shared_0c_s
{
const uint32_t *ptr;
size_t meta;
}
Eurydice_dst_ref_shared_0c;
/**
A monomorphic instance of const_generics.serialize
with const generics
- OUT_LEN= 8
*/
Eurydice_array_u8x8 const_generics_serialize_70(Eurydice_dst_ref_shared_0c re);
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $2size_t
*/
typedef struct Eurydice_arr_a0_s { uint32_t data[2U]; } Eurydice_arr_a0;
void const_generics_main(void);
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
/**
A monomorphic instance of const_generics.Pair
with types uint32_t, uint32_t
with const generics
- $2size_t
- $2size_t
*/
typedef struct const_generics_Pair_30_s
{
Eurydice_arr_a0 left;
Eurydice_arr_a0 right;
}
const_generics_Pair_30;
/**
A monomorphic instance of Eurydice.arr
with types uint64_t
with const generics
- $4size_t
*/
typedef struct Eurydice_arr_e4_s { uint64_t data[4U]; } Eurydice_arr_e4;
/**
A monomorphic instance of const_generics.Pair
with types uint32_t, uint64_t
with const generics
- $2size_t
- $4size_t
*/
typedef struct const_generics_Pair_67_s
{
Eurydice_arr_a0 left;
Eurydice_arr_e4 right;
}
const_generics_Pair_67;
/**
A monomorphic instance of const_generics.Pair
with types uint64_t, uint32_t
with const generics
- $4size_t
- $2size_t
*/
typedef struct const_generics_Pair_54_s
{
Eurydice_arr_e4 left;
Eurydice_arr_a0 right;
}
const_generics_Pair_54;
/**
A monomorphic instance of const_generics.mk_pairs
with types uint32_t, uint64_t
with const generics
- N= 2
- M= 4
*/
const_generics_Pair_30 const_generics_mk_pairs_67(uint32_t x, uint64_t y);
void const_generics_main1(void);
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $1size_t
*/
typedef struct Eurydice_arr_d5_s { uint32_t data[1U]; } Eurydice_arr_d5;
/**
A monomorphic instance of Eurydice.arr
with types size_t
with const generics
- $1size_t
*/
typedef struct Eurydice_arr_58_s { size_t data[1U]; } Eurydice_arr_58;
/**
A monomorphic instance of const_generics.f
with const generics
- FOO= 1
- BAR= 2
*/
bool const_generics_f_06(uint32_t x, size_t y);
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $3size_t
*/
typedef struct Eurydice_arr_a5_s { uint32_t data[3U]; } Eurydice_arr_a5;
/**
A monomorphic instance of Eurydice.arr
with types size_t
with const generics
- $3size_t
*/
typedef struct Eurydice_arr_eb_s { size_t data[3U]; } Eurydice_arr_eb;
/**
A monomorphic instance of const_generics.f
with const generics
- FOO= 3
- BAR= 4
*/
bool const_generics_f_16(uint32_t x, size_t y);
/**
A monomorphic instance of const_generics.g
with const generics
- BAR= 3
- FOO= 4
*/
bool const_generics_g_16(uint32_t x, size_t y);
void const_generics_main3(void);
extern uint32_t core_clone_impls__core__clone__Clone_for_u32__clone(const uint32_t *x0);
extern uint64_t core_clone_impls__core__clone__Clone_for_u64__clone(const uint64_t *x0);
extern uint8_t core_clone_impls__core__clone__Clone_for_u8__clone(const uint8_t *x0);
#if defined(__cplusplus)
}
#endif
#define const_generics_H_DEFINED
#endif /* const_generics_H */
================================================
FILE: out/test-core_num/core_num.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "core_num.h"
typedef struct const_uint32_t__x2_s
{
const uint32_t *fst;
const uint32_t *snd;
}
const_uint32_t__x2;
void core_num_main(void)
{
uint32_t x = CORE_NUM__U32__BITS;
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 32U;
const_uint32_t__x2 uu____0 = { .fst = &x, .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
================================================
FILE: out/test-core_num/core_num.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef core_num_H
#define core_num_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
static inline uint32_t core_num__u32__count_ones(uint32_t x0);
#define CORE_NUM__U32__MAX (~0U)
#define CORE_NUM__U32__BITS (core_num__u32__count_ones(CORE_NUM__U32__MAX))
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
void core_num_main(void);
#if defined(__cplusplus)
}
#endif
#define core_num_H_DEFINED
#endif /* core_num_H */
================================================
FILE: out/test-dst/dst.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "dst.h"
Eurydice_dst_ref_mut_2f dst_alloc(void)
{
return
(
KRML_CLITERAL(Eurydice_dst_ref_mut_2f){
.ptr = (dst_T *)Eurydice_box_new((
KRML_CLITERAL(dst_S_e9){ .foo = 0U, .my_data = { .data = { 0U } } }
),
dst_S_e9,
dst_S_e9 *),
.meta = (size_t)4U
}
);
}
Eurydice_dst_ref_mut_bb dst_alloc3(void)
{
return
(
KRML_CLITERAL(Eurydice_dst_ref_mut_bb){
.ptr = (dst_T3 *)Eurydice_box_new((
KRML_CLITERAL(dst_S_93){
.foo = 0U,
.my_data = {
.data = {
{ .data = { 0U } },
{ .data = { 0U } },
{ .data = { 0U } },
{ .data = { 0U } }
}
}
}
),
dst_S_93,
dst_S_93 *),
.meta = (size_t)4U
}
);
}
typedef struct const_uint32_t__x2_s
{
const uint32_t *fst;
const uint32_t *snd;
}
const_uint32_t__x2;
void dst_check_regular_field(Eurydice_dst_ref_mut_2f x)
{
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2 uu____0 = { .fst = &x.ptr->foo, .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
void dst_check_regular_field_ref(Eurydice_dst_ref_shared_2f x)
{
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2 uu____0 = { .fst = &x.ptr->foo, .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
void dst_check_var_field(Eurydice_dst_ref_mut_2f x)
{
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2
uu____0 = { .fst = &((const uint32_t *)x.ptr->my_data)[0U], .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
void dst_check_var_field_ref(Eurydice_dst_ref_shared_2f x)
{
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2
uu____0 = { .fst = &((const uint32_t *)x.ptr->my_data)[0U], .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
void dst_check_var_field_ref3(Eurydice_dst_ref_shared_bb x)
{
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2
uu____0 = { .fst = ((const Eurydice_arr_a5 *)x.ptr->my_data)->data, .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
void dst_main3(void)
{
Eurydice_dst_ref_mut_bb x = dst_alloc3();
const Eurydice_dst_ref_mut_bb *uu____0 = &x;
dst_check_var_field_ref3((
KRML_CLITERAL(Eurydice_dst_ref_shared_bb){ .ptr = uu____0->ptr, .meta = uu____0->meta }
));
}
Eurydice_dst_ref_mut_b7 dst_mk(void)
{
dst_T2_e9 x = { .header = (size_t)0U, .my_data = { .data = { 0U } } };
x.my_data.data[1U] = 2U;
return
(
KRML_CLITERAL(Eurydice_dst_ref_mut_b7){
.ptr = (dst_T2_be *)Eurydice_box_new(x, dst_T2_e9, dst_T2_e9 *),
.meta = (size_t)4U
}
);
}
/**
A monomorphic instance of Eurydice.array_to_slice_mut
with types uint32_t
with const generics
- N= 4
*/
static Eurydice_dst_ref_mut_0c array_to_slice_mut_32(Eurydice_arr_e5 *a)
{
Eurydice_dst_ref_mut_0c lit;
lit.ptr = a->data;
lit.meta = (size_t)4U;
return lit;
}
void dst_main4(void)
{
Eurydice_dst_ref_mut_0c
x =
array_to_slice_mut_32(Eurydice_box_new((KRML_CLITERAL(Eurydice_arr_e5){ .data = { 0U } }),
Eurydice_arr_e5,
Eurydice_arr_e5 *));
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 0U;
const_uint32_t__x2 uu____0 = { .fst = &x.ptr[3U], .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
void dst_main(void)
{
dst_check_regular_field(dst_alloc());
dst_check_var_field(dst_alloc());
dst_S_e9 x = { .foo = 0U, .my_data = { .data = { 0U } } };
Eurydice_dst_ref_shared_2f x0 = { .ptr = (const dst_T *)&x, .meta = (size_t)4U };
dst_check_regular_field_ref(x0);
dst_check_var_field_ref(x0);
dst_main3();
Eurydice_dst_ref_mut_b7 uu____0 = dst_mk();
/* original Rust expression is not an lvalue in C */
uint32_t lvalue0 = 0U;
const_uint32_t__x2
uu____1 = { .fst = &((const uint32_t *)uu____0.ptr->my_data)[0U], .snd = &lvalue0 };
EURYDICE_ASSERT(uu____1.fst[0U] == uu____1.snd[0U], "panic!");
Eurydice_dst_ref_mut_b7 uu____2 = dst_mk();
/* original Rust expression is not an lvalue in C */
uint32_t lvalue = 2U;
const_uint32_t__x2
uu____3 = { .fst = &((const uint32_t *)uu____2.ptr->my_data)[1U], .snd = &lvalue };
EURYDICE_ASSERT(uu____3.fst[0U] == uu____3.snd[0U], "panic!");
dst_main4();
}
================================================
FILE: out/test-dst/dst.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef dst_H
#define dst_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
typedef struct dst_T_s
{
uint32_t foo;
uint32_t my_data[];
}
dst_T;
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $3size_t
*/
typedef struct Eurydice_arr_a5_s { uint32_t data[3U]; } Eurydice_arr_a5;
typedef struct dst_T3_s
{
uint32_t foo;
Eurydice_arr_a5 my_data[];
}
dst_T3;
/**
A monomorphic instance of Eurydice.dst_ref_mut
with types dst_T, size_t
*/
typedef struct Eurydice_dst_ref_mut_2f_s
{
dst_T *ptr;
size_t meta;
}
Eurydice_dst_ref_mut_2f;
/**
A monomorphic instance of Eurydice.arr
with types uint32_t
with const generics
- $4size_t
*/
typedef struct Eurydice_arr_e5_s { uint32_t data[4U]; } Eurydice_arr_e5;
/**
A monomorphic instance of dst.S
with types Eurydice_arr_e5
*/
typedef struct dst_S_e9_s
{
uint32_t foo;
Eurydice_arr_e5 my_data;
}
dst_S_e9;
Eurydice_dst_ref_mut_2f dst_alloc(void);
/**
A monomorphic instance of Eurydice.dst_ref_mut
with types dst_T3, size_t
*/
typedef struct Eurydice_dst_ref_mut_bb_s
{
dst_T3 *ptr;
size_t meta;
}
Eurydice_dst_ref_mut_bb;
/**
A monomorphic instance of Eurydice.arr
with types Eurydice_arr_a5
with const generics
- $4size_t
*/
typedef struct Eurydice_arr_53_s { Eurydice_arr_a5 data[4U]; } Eurydice_arr_53;
/**
A monomorphic instance of dst.S
with types Eurydice_arr_53
*/
typedef struct dst_S_93_s
{
uint32_t foo;
Eurydice_arr_53 my_data;
}
dst_S_93;
Eurydice_dst_ref_mut_bb dst_alloc3(void);
void dst_check_regular_field(Eurydice_dst_ref_mut_2f x);
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types dst_T, size_t
*/
typedef struct Eurydice_dst_ref_shared_2f_s
{
const dst_T *ptr;
size_t meta;
}
Eurydice_dst_ref_shared_2f;
void dst_check_regular_field_ref(Eurydice_dst_ref_shared_2f x);
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types uint32_t, size_t
*/
typedef struct Eurydice_dst_ref_shared_0c_s
{
const uint32_t *ptr;
size_t meta;
}
Eurydice_dst_ref_shared_0c;
void dst_check_var_field(Eurydice_dst_ref_mut_2f x);
void dst_check_var_field_ref(Eurydice_dst_ref_shared_2f x);
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types dst_T3, size_t
*/
typedef struct Eurydice_dst_ref_shared_bb_s
{
const dst_T3 *ptr;
size_t meta;
}
Eurydice_dst_ref_shared_bb;
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types Eurydice_arr_a5, size_t
*/
typedef struct Eurydice_dst_ref_shared_d3_s
{
const Eurydice_arr_a5 *ptr;
size_t meta;
}
Eurydice_dst_ref_shared_d3;
void dst_check_var_field_ref3(Eurydice_dst_ref_shared_bb x);
void dst_main3(void);
typedef struct dst_T2_be_s dst_T2_be;
/**
A monomorphic instance of Eurydice.dst_ref_mut
with types dst_T2_be, size_t
*/
typedef struct Eurydice_dst_ref_mut_b7_s
{
dst_T2_be *ptr;
size_t meta;
}
Eurydice_dst_ref_mut_b7;
/**
A monomorphic instance of dst.T2
with types Eurydice_arr_e5
*/
typedef struct dst_T2_e9_s
{
size_t header;
Eurydice_arr_e5 my_data;
}
dst_T2_e9;
Eurydice_dst_ref_mut_b7 dst_mk(void);
/**
A monomorphic instance of Eurydice.dst_ref_mut
with types uint32_t, size_t
*/
typedef struct Eurydice_dst_ref_mut_0c_s
{
uint32_t *ptr;
size_t meta;
}
Eurydice_dst_ref_mut_0c;
void dst_main4(void);
/**
A monomorphic instance of dst.T2
with types Eurydice_derefed_slice uint32_t
*/
typedef struct dst_T2_be_s
{
size_t header;
uint32_t my_data[];
}
dst_T2_be;
void dst_main(void);
#if defined(__cplusplus)
}
#endif
#define dst_H_DEFINED
#endif /* dst_H */
================================================
FILE: out/test-dyn_trait_struct_type/dyn_trait_struct_type.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "dyn_trait_struct_type.h"
void dyn_trait_struct_type_main(void)
{
}
void dyn_trait_struct_type_use_trait(Eurydice_dst_ref_shared_06 t)
{
Eurydice_dst_ref_shared_06 uu____0 = t;
uu____0.meta->method_method(uu____0);
}
================================================
FILE: out/test-dyn_trait_struct_type/dyn_trait_struct_type.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef dyn_trait_struct_type_H
#define dyn_trait_struct_type_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
typedef struct core_marker_MetaSized__vtable__s core_marker_MetaSized__vtable_;
/**
A monomorphic instance of Eurydice.dst_ref_mut
with types Eurydice_c_void_t, core_marker_MetaSized_{vtable}*
*/
typedef struct Eurydice_dst_ref_mut_05_s
{
Eurydice_c_void_t *ptr;
core_marker_MetaSized__vtable_ *meta;
}
Eurydice_dst_ref_mut_05;
typedef struct core_marker_MetaSized__vtable__s
{
size_t size;
size_t align;
void (*drop)(Eurydice_dst_ref_mut_05 x0);
}
core_marker_MetaSized__vtable_;
void dyn_trait_struct_type_main(void);
typedef struct dyn_trait_struct_type_Trait__vtable__s dyn_trait_struct_type_Trait__vtable_;
/**
A monomorphic instance of Eurydice.dst_ref_mut
with types Eurydice_c_void_t, dyn_trait_struct_type_Trait_{vtable}*
*/
typedef struct Eurydice_dst_ref_mut_06_s
{
Eurydice_c_void_t *ptr;
dyn_trait_struct_type_Trait__vtable_ *meta;
}
Eurydice_dst_ref_mut_06;
/**
A monomorphic instance of Eurydice.dst_ref_shared
with types Eurydice_c_void_t, dyn_trait_struct_type_Trait_{vtable}*
*/
typedef struct Eurydice_dst_ref_shared_06_s
{
const Eurydice_c_void_t *ptr;
dyn_trait_struct_type_Trait__vtable_ *meta;
}
Eurydice_dst_ref_shared_06;
typedef struct dyn_trait_struct_type_Trait__vtable__s
{
size_t size;
size_t align;
void (*drop)(Eurydice_dst_ref_mut_06 x0);
void (*method_method)(Eurydice_dst_ref_shared_06 x0);
const core_marker_MetaSized__vtable_ *super_trait_0;
}
dyn_trait_struct_type_Trait__vtable_;
void dyn_trait_struct_type_use_trait(Eurydice_dst_ref_shared_06 t);
#if defined(__cplusplus)
}
#endif
#define dyn_trait_struct_type_H_DEFINED
#endif /* dyn_trait_struct_type_H */
================================================
FILE: out/test-floating_points/floating_points.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "floating_points.h"
typedef struct const_float32_t__x2_s
{
const float32_t *fst;
const float32_t *snd;
}
const_float32_t__x2;
typedef struct const_float64_t__x2_s
{
const float64_t *fst;
const float64_t *snd;
}
const_float64_t__x2;
typedef struct const_size_t__x2_s
{
const size_t *fst;
const size_t *snd;
}
const_size_t__x2;
void floating_points_main(void)
{
float32_t f = (float32_t)1;
Eurydice_arr_fe arr;
float32_t repeat_expression0[100U];
for (size_t i = (size_t)0U; i < (size_t)100U; i++)
{
repeat_expression0[i] = f;
}
memcpy(arr.data, repeat_expression0, (size_t)100U * sizeof (float32_t));
float64_t d = (float64_t)1;
Eurydice_arr_9f arr2;
float64_t repeat_expression[100U];
for (size_t i = (size_t)0U; i < (size_t)100U; i++)
{
repeat_expression[i] = d;
}
memcpy(arr2.data, repeat_expression, (size_t)100U * sizeof (float64_t));
/* original Rust expression is not an lvalue in C */
float32_t lvalue0 = (float32_t)1;
const_float32_t__x2 uu____0 = { .fst = arr.data, .snd = &lvalue0 };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
/* original Rust expression is not an lvalue in C */
float64_t lvalue1 = (float64_t)1;
const_float64_t__x2 uu____1 = { .fst = arr2.data, .snd = &lvalue1 };
EURYDICE_ASSERT(uu____1.fst[0U] == uu____1.snd[0U], "panic!");
/* original Rust expression is not an lvalue in C */
size_t lvalue2 = (size_t)100U;
/* original Rust expression is not an lvalue in C */
size_t lvalue3 = (size_t)100U;
const_size_t__x2 uu____2 = { .fst = &lvalue2, .snd = &lvalue3 };
EURYDICE_ASSERT(uu____2.fst[0U] == uu____2.snd[0U], "panic!");
/* original Rust expression is not an lvalue in C */
size_t lvalue4 = (size_t)100U;
/* original Rust expression is not an lvalue in C */
size_t lvalue = (size_t)100U;
const_size_t__x2 uu____3 = { .fst = &lvalue4, .snd = &lvalue };
EURYDICE_ASSERT(uu____3.fst[0U] == uu____3.snd[0U], "panic!");
}
================================================
FILE: out/test-floating_points/floating_points.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef floating_points_H
#define floating_points_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
/**
A monomorphic instance of Eurydice.arr
with types float32_t
with const generics
- $100size_t
*/
typedef struct Eurydice_arr_fe_s { float32_t data[100U]; } Eurydice_arr_fe;
/**
A monomorphic instance of Eurydice.arr
with types float64_t
with const generics
- $100size_t
*/
typedef struct Eurydice_arr_9f_s { float64_t data[100U]; } Eurydice_arr_9f;
void floating_points_main(void);
#if defined(__cplusplus)
}
#endif
#define floating_points_H_DEFINED
#endif /* floating_points_H */
================================================
FILE: out/test-fn_cast/fn_cast.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "fn_cast.h"
/**
A monomorphic instance of fn_cast.applies
with types int32_t, int32_t
*/
const int32_t *fn_cast_applies_99(const int32_t *(*f)(const int32_t *x0), const int32_t *arg)
{
return f(arg);
}
/**
A monomorphic instance of fn_cast.id_ref
with types int32_t
*/
const int32_t *fn_cast_id_ref_a8(const int32_t *x)
{
return x;
}
typedef struct const_int32_t__x2_s
{
const int32_t *fst;
const int32_t *snd;
}
const_int32_t__x2;
void fn_cast_main(void)
{
/* original Rust expression is not an lvalue in C */
int32_t lvalue0 = 1;
/* original Rust expression is not an lvalue in C */
int32_t lvalue = 1;
const_int32_t__x2
uu____0 =
{
.fst = fn_cast_applies_99((const int32_t *(*)(const int32_t *x0))fn_cast_id_ref_a8, &lvalue0),
.snd = &lvalue
};
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
================================================
FILE: out/test-fn_cast/fn_cast.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef fn_cast_H
#define fn_cast_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
/**
A monomorphic instance of fn_cast.applies
with types int32_t, int32_t
*/
const int32_t *fn_cast_applies_99(const int32_t *(*f)(const int32_t *x0), const int32_t *arg);
/**
A monomorphic instance of fn_cast.id_ref
with types int32_t
*/
const int32_t *fn_cast_id_ref_a8(const int32_t *x);
void fn_cast_main(void);
#if defined(__cplusplus)
}
#endif
#define fn_cast_H_DEFINED
#endif /* fn_cast_H */
================================================
FILE: out/test-fn_higher_order/fn_higher_order.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "fn_higher_order.h"
int32_t fn_higher_order_empty_ptr(int32_t (*f)(void))
{
return f();
}
int32_t fn_higher_order_more_sum_lst(const Eurydice_arr_bf *l)
{
int32_t sum = 0;
KRML_MAYBE_FOR3(i,
(size_t)0U,
(size_t)3U,
(size_t)1U,
size_t i0 = i;
sum += l->data[i0];);
return sum;
}
/**
A monomorphic instance of fn_higher_order.compose_cg_apply
with types size_t, size_t, size_t
with const generics
- N= 5
*/
size_t
fn_higher_order_compose_cg_apply_4d(
size_t (*f)(const Eurydice_arr_2b *x0),
size_t (*g)(size_t x0),
const Eurydice_arr_2b *arg
)
{
size_t (*uu____0)(size_t x0) = g;
return uu____0(f(arg));
}
/**
A monomorphic instance of fn_higher_order.sum_lst
with const generics
- N= 5
*/
size_t fn_higher_order_sum_lst_a5(const Eurydice_arr_2b *lst)
{
size_t sum = (size_t)0U;
KRML_MAYBE_FOR5(i,
(size_t)0U,
(size_t)5U,
(size_t)1U,
size_t i0 = i;
sum += lst->data[i0];);
return sum + (size_t)5U;
}
/**
A monomorphic instance of fn_higher_order.id
with types size_t
*/
size_t fn_higher_order_id_60(size_t r)
{
return r;
}
/**
A monomorphic instance of fn_higher_order.compose_cg_apply
with types int32_t, int32_t, int32_t
with const generics
- N= 3
*/
int32_t
fn_higher_order_compose_cg_apply_36(
int32_t (*f)(const Eurydice_arr_bf *x0),
int32_t (*g)(int32_t x0),
const Eurydice_arr_bf *arg
)
{
int32_t (*uu____0)(int32_t x0) = g;
return uu____0(f(arg));
}
/**
A monomorphic instance of fn_higher_order.id
with types int32_t
*/
int32_t fn_higher_order_id_a8(int32_t r)
{
return r;
}
typedef struct const_size_t__x2_s
{
const size_t *fst;
const size_t *snd;
}
const_size_t__x2;
typedef struct const_int32_t__x2_s
{
const int32_t *fst;
const int32_t *snd;
}
const_int32_t__x2;
void fn_higher_order_use_compose_cg(void)
{
/* original Rust expression is not an lvalue in C */
Eurydice_arr_2b
lvalue0 = { .data = { (size_t)1U, (size_t)2U, (size_t)3U, (size_t)4U, (size_t)5U } };
size_t
x =
fn_higher_order_compose_cg_apply_4d(fn_higher_order_sum_lst_a5,
fn_higher_order_id_60,
&lvalue0);
/* original Rust expression is not an lvalue in C */
Eurydice_arr_bf lvalue1 = { .data = { 10, 11, 12 } };
int32_t
y =
fn_higher_order_compose_cg_apply_36(fn_higher_order_more_sum_lst,
fn_higher_order_id_a8,
&lvalue1);
/* original Rust expression is not an lvalue in C */
size_t lvalue = (size_t)20U;
const_size_t__x2 uu____0 = { .fst = &x, .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
/* original Rust expression is not an lvalue in C */
int32_t lvalue2 = 33;
const_int32_t__x2 uu____1 = { .fst = &y, .snd = &lvalue2 };
EURYDICE_ASSERT(uu____1.fst[0U] == uu____1.snd[0U], "panic!");
}
void fn_higher_order_main(void)
{
fn_higher_order_use_compose_cg();
}
void fn_higher_order_unit_empty_ptr(void (*f)(void))
{
f();
}
================================================
FILE: out/test-fn_higher_order/fn_higher_order.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef fn_higher_order_H
#define fn_higher_order_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
extern int32_t core_clone_impls__core__clone__Clone_for_i32__clone(const int32_t *x0);
extern size_t core_clone_impls__core__clone__Clone_for_usize__clone(const size_t *x0);
#define core_cmp_Ordering_Less -1
#define core_cmp_Ordering_Equal 0
#define core_cmp_Ordering_Greater 1
typedef int8_t core_cmp_Ordering;
extern bool
core_cmp_impls__core__cmp__PartialEq_usize__for_usize__eq(const size_t *x0, const size_t *x1);
#define core_option_None 0
#define core_option_Some 1
typedef uint8_t core_option_Option_77_tags;
/**
A monomorphic instance of core.option.Option
with types core_cmp_Ordering
*/
typedef struct core_option_Option_77_s
{
core_option_Option_77_tags tag;
core_cmp_Ordering f0;
}
core_option_Option_77;
extern core_option_Option_77
core_cmp_impls__core__cmp__PartialOrd_usize__for_usize__partial_cmp(
const size_t *x0,
const size_t *x1
);
/**
A monomorphic instance of core.option.Option
with types size_t
*/
typedef struct core_option_Option_87_s
{
core_option_Option_77_tags tag;
size_t f0;
}
core_option_Option_87;
extern core_option_Option_87
core_iter_range__core__iter__range__Step_for_usize__backward_checked(size_t x0, size_t x1);
extern core_option_Option_87
core_iter_range__core__iter__range__Step_for_usize__forward_checked(size_t x0, size_t x1);
/**
A monomorphic instance of n-tuple
with types size_t, core_option_Option_87
*/
typedef struct tuple_21_s
{
size_t fst;
core_option_Option_87 snd;
}
tuple_21;
extern tuple_21
core_iter_range__core__iter__range__Step_for_usize__steps_between(
const size_t *x0,
const size_t *x1
);
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
int32_t fn_higher_order_empty_ptr(int32_t (*f)(void));
/**
A monomorphic instance of Eurydice.arr
with types int32_t
with const generics
- $3size_t
*/
typedef struct Eurydice_arr_bf_s { int32_t data[3U]; } Eurydice_arr_bf;
int32_t fn_higher_order_more_sum_lst(const Eurydice_arr_bf *l);
/**
A monomorphic instance of Eurydice.arr
with types size_t
with const generics
- $5size_t
*/
typedef struct Eurydice_arr_2b_s { size_t data[5U]; } Eurydice_arr_2b;
/**
A monomorphic instance of fn_higher_order.compose_cg_apply
with types size_t, size_t, size_t
with const generics
- N= 5
*/
size_t
fn_higher_order_compose_cg_apply_4d(
size_t (*f)(const Eurydice_arr_2b *x0),
size_t (*g)(size_t x0),
const Eurydice_arr_2b *arg
);
/**
A monomorphic instance of fn_higher_order.sum_lst
with const generics
- N= 5
*/
size_t fn_higher_order_sum_lst_a5(const Eurydice_arr_2b *lst);
/**
A monomorphic instance of fn_higher_order.id
with types size_t
*/
size_t fn_higher_order_id_60(size_t r);
/**
A monomorphic instance of fn_higher_order.compose_cg_apply
with types int32_t, int32_t, int32_t
with const generics
- N= 3
*/
int32_t
fn_higher_order_compose_cg_apply_36(
int32_t (*f)(const Eurydice_arr_bf *x0),
int32_t (*g)(int32_t x0),
const Eurydice_arr_bf *arg
);
/**
A monomorphic instance of fn_higher_order.id
with types int32_t
*/
int32_t fn_higher_order_id_a8(int32_t r);
void fn_higher_order_use_compose_cg(void);
void fn_higher_order_main(void);
void fn_higher_order_unit_empty_ptr(void (*f)(void));
#if defined(__cplusplus)
}
#endif
#define fn_higher_order_H_DEFINED
#endif /* fn_higher_order_H */
================================================
FILE: out/test-for/for.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "for.h"
void for_main(void)
{
}
uint8_t for_other(Eurydice_borrow_slice_u8 input)
{
for (int32_t i = 0; i < 5; i++)
{
int32_t i0 = i;
if (i0 == 2)
{
return 6U;
}
}
return input.ptr[0U];
}
================================================
FILE: out/test-for/for.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef for_H
#define for_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
extern int32_t core_clone_impls__core__clone__Clone_for_i32__clone(const int32_t *x0);
#define core_cmp_Ordering_Less -1
#define core_cmp_Ordering_Equal 0
#define core_cmp_Ordering_Greater 1
typedef int8_t core_cmp_Ordering;
extern bool
core_cmp_impls__core__cmp__PartialEq_i32__for_i32__eq(const int32_t *x0, const int32_t *x1);
#define core_option_None 0
#define core_option_Some 1
typedef uint8_t core_option_Option_77_tags;
/**
A monomorphic instance of core.option.Option
with types core_cmp_Ordering
*/
typedef struct core_option_Option_77_s
{
core_option_Option_77_tags tag;
core_cmp_Ordering f0;
}
core_option_Option_77;
extern core_option_Option_77
core_cmp_impls__core__cmp__PartialOrd_i32__for_i32__partial_cmp(
const int32_t *x0,
const int32_t *x1
);
/**
A monomorphic instance of core.option.Option
with types int32_t
*/
typedef struct core_option_Option_9e_s
{
core_option_Option_77_tags tag;
int32_t f0;
}
core_option_Option_9e;
extern core_option_Option_9e
core_iter_range__core__iter__range__Step_for_i32__backward_checked(int32_t x0, size_t x1);
extern core_option_Option_9e
core_iter_range__core__iter__range__Step_for_i32__forward_checked(int32_t x0, size_t x1);
/**
A monomorphic instance of core.option.Option
with types size_t
*/
typedef struct core_option_Option_87_s
{
core_option_Option_77_tags tag;
size_t f0;
}
core_option_Option_87;
/**
A monomorphic instance of n-tuple
with types size_t, core_option_Option_87
*/
typedef struct tuple_21_s
{
size_t fst;
core_option_Option_87 snd;
}
tuple_21;
extern tuple_21
core_iter_range__core__iter__range__Step_for_i32__steps_between(
const int32_t *x0,
const int32_t *x1
);
void for_main(void);
uint8_t for_other(Eurydice_borrow_slice_u8 input);
#if defined(__cplusplus)
}
#endif
#define for_H_DEFINED
#endif /* for_H */
================================================
FILE: out/test-global_ref/global_ref.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "global_ref.h"
static void *C_VAL_local_0 = (void *)0U;
static void *const *C_VAL_local_1 = &C_VAL_local_0;
void *const *const *global_ref_C_VAL_local_2 = &C_VAL_local_1;
static int32_t S_VAL_local_0 = 0;
static const int32_t *S_VAL_local_1 = &S_VAL_local_0;
static const int32_t *const *S_VAL_local_2 = &S_VAL_local_1;
const int32_t *const *const *const global_ref_S_VAL = &S_VAL_local_2;
typedef struct const_____x2_s
{
void *const *fst;
void *const *snd;
}
const_____x2;
void global_ref_main(void)
{
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
const_____x2 uu____0 = { .fst = GLOBAL_REF_C_VAL[0U][0U], .snd = &lvalue };
EURYDICE_ASSERT(core_cmp_impls__core__cmp__PartialEq_____for_____eq(uu____0.fst, uu____0.snd),
"panic!");
EURYDICE_ASSERT(global_ref_S_VAL[0U][0U][0U] == 0, "panic!");
}
================================================
FILE: out/test-global_ref/global_ref.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef global_ref_H
#define global_ref_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
extern bool
core_cmp_impls__core__cmp__PartialEq_____for_____eq(void *const *x0, void *const *x1);
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
extern void *const *const *global_ref_C_VAL_local_2;
#define GLOBAL_REF_C_VAL (&global_ref_C_VAL_local_2)
extern const int32_t *const *const *const global_ref_S_VAL;
void global_ref_main(void);
#if defined(__cplusplus)
}
#endif
#define global_ref_H_DEFINED
#endif /* global_ref_H */
================================================
FILE: out/test-i32_shl/i32_shl.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "i32_shl.h"
typedef struct const_int16_t__x2_s
{
const int16_t *fst;
const int16_t *snd;
}
const_int16_t__x2;
void i32_shl_main(void)
{
int16_t x = (int16_t)((uint32_t)-1 << 8U);
/* original Rust expression is not an lvalue in C */
int16_t lvalue0 = -256;
const_int16_t__x2 uu____0 = { .fst = &x, .snd = &lvalue0 };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
int16_t y = (int16_t)((uint32_t)(-1 & (int16_t)65280U) << 8U) >> 8U;
/* original Rust expression is not an lvalue in C */
int16_t lvalue = 0;
const_int16_t__x2 uu____1 = { .fst = &y, .snd = &lvalue };
EURYDICE_ASSERT(uu____1.fst[0U] == uu____1.snd[0U], "panic!");
}
================================================
FILE: out/test-i32_shl/i32_shl.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef i32_shl_H
#define i32_shl_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
void i32_shl_main(void);
#if defined(__cplusplus)
}
#endif
#define i32_shl_H_DEFINED
#endif /* i32_shl_H */
================================================
FILE: out/test-inline_attributes/inline_attributes.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "inline_attributes.h"
inline uint32_t inline_attributes_f(void)
{
return 1U;
}
KRML_NOINLINE uint32_t inline_attributes_g(void)
{
return 2U;
}
KRML_MUSTINLINE uint32_t inline_attributes_h(void)
{
return 3U;
}
void inline_attributes_main(void)
{
inline_attributes_f();
inline_attributes_g();
inline_attributes_h();
}
================================================
FILE: out/test-inline_attributes/inline_attributes.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef inline_attributes_H
#define inline_attributes_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
uint32_t inline_attributes_f(void);
uint32_t inline_attributes_g(void);
uint32_t inline_attributes_h(void);
void inline_attributes_main(void);
#if defined(__cplusplus)
}
#endif
#define inline_attributes_H_DEFINED
#endif /* inline_attributes_H */
================================================
FILE: out/test-int_switch/int_switch.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "int_switch.h"
uint32_t int_switch_f(void)
{
return 0U;
}
void int_switch_main(void)
{
switch (int_switch_f())
{
case 0U:
{
break;
}
case 1U:
{
KRML_HOST_EPRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, "panic!");
KRML_HOST_EXIT(255U);
break;
}
default:
{
KRML_HOST_EPRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, "panic!");
KRML_HOST_EXIT(255U);
}
}
}
================================================
FILE: out/test-int_switch/int_switch.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef int_switch_H
#define int_switch_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
uint32_t int_switch_f(void);
void int_switch_main(void);
#if defined(__cplusplus)
}
#endif
#define int_switch_H_DEFINED
#endif /* int_switch_H */
================================================
FILE: out/test-issue_102/issue_102.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "issue_102.h"
void issue_102_main(void)
{
}
================================================
FILE: out/test-issue_102/issue_102.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef issue_102_H
#define issue_102_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
#define issue_102_Error1_Reason1 1
#define issue_102_Error1_Reason2 2
typedef uint8_t issue_102_Error1;
#define issue_102_Error2_Reason1 3
#define issue_102_Error2_Reason2 4
typedef uint8_t issue_102_Error2;
void issue_102_main(void);
#if defined(__cplusplus)
}
#endif
#define issue_102_H_DEFINED
#endif /* issue_102_H */
================================================
FILE: out/test-issue_104/issue_104.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "issue_104.h"
/**
A monomorphic instance of issue_104.sth
with types issue_104_S
with const generics
*/
uint8_t issue_104_sth_50(void)
{
return ISSUE_104__ISSUE_104__FUN_FOR_ISSUE_104__S__VAL;
}
uint8_t issue_104_call(void)
{
return issue_104_sth_50();
}
typedef struct const_uint8_t__x2_s
{
const uint8_t *fst;
const uint8_t *snd;
}
const_uint8_t__x2;
void issue_104_main(void)
{
/* original Rust expression is not an lvalue in C */
uint8_t lvalue0 = issue_104_call();
/* original Rust expression is not an lvalue in C */
uint8_t lvalue = 5U;
const_uint8_t__x2 uu____0 = { .fst = &lvalue0, .snd = &lvalue };
EURYDICE_ASSERT(uu____0.fst[0U] == uu____0.snd[0U], "panic!");
}
================================================
FILE: out/test-issue_104/issue_104.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef issue_104_H
#define issue_104_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
#define ISSUE_104__ISSUE_104__FUN_FOR_ISSUE_104__S__VAL (5U)
/**
A monomorphic instance of issue_104.sth
with types issue_104_S
with const generics
*/
uint8_t issue_104_sth_50(void);
uint8_t issue_104_call(void);
void issue_104_main(void);
#if defined(__cplusplus)
}
#endif
#define issue_104_H_DEFINED
#endif /* issue_104_H */
================================================
FILE: out/test-issue_105/issue_105.c
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#include "issue_105.h"
/**
This function found in impl {core::cmp::PartialEq<()> for ()}
*/
inline bool core_cmp_impls_eq_cf(void *const *self, void *const *_other)
{
return true;
}
/**
This function found in impl {core::cmp::PartialEq<()> for ()}
*/
inline bool core_cmp_impls_ne_cf(void *const *self, void *const *_other)
{
return false;
}
/**
This function found in impl {core::cmp::PartialEq for u8}
*/
inline bool core_cmp_impls_eq_c3(const uint8_t *self, const uint8_t *other)
{
return self[0U] == other[0U];
}
/**
This function found in impl {core::cmp::PartialEq for u8}
*/
inline bool core_cmp_impls_ne_c3(const uint8_t *self, const uint8_t *other)
{
return self[0U] != other[0U];
}
core_result_Result_1d issue_105_inner(void)
{
return (KRML_CLITERAL(core_result_Result_1d){ .tag = core_result_Err, .f0 = 1U });
}
/**
This function found in impl {core::ops::try_trait::Try[core::marker::Sized, TraitClause@1]> for core::result::Result[TraitClause@0, TraitClause@1]}
*/
/**
A monomorphic instance of core.result.branch_71
with types (), uint8_t
*/
inline core_ops_control_flow_ControlFlow_19
core_result_branch_71_e9(core_result_Result_1d self)
{
if (!(self.tag == core_result_Ok))
{
uint8_t e = self.f0;
return
(
KRML_CLITERAL(core_ops_control_flow_ControlFlow_19){
.tag = core_ops_control_flow_Break,
.f0 = { .tag = core_result_Err, .val = { .case_Err = e } }
}
);
}
return
(KRML_CLITERAL(core_ops_control_flow_ControlFlow_19){ .tag = core_ops_control_flow_Continue });
}
/**
This function found in impl {core::ops::try_trait::FromResidual[core::marker::Sized, TraitClause@1]> for core::result::Result[TraitClause@0, TraitClause@2]}
*/
/**
A monomorphic instance of core.result.from_residual_1f
with types (), uint8_t, uint8_t
with const generics
*/
inline core_result_Result_1d core_result_from_residual_1f_48(core_result_Result_8f residual)
{
uint8_t e = residual.val.case_Err;
return
(
KRML_CLITERAL(core_result_Result_1d){
.tag = core_result_Err,
.f0 = core_convert_from_61_90(e)
}
);
}
core_result_Result_1d issue_105_call_it(void)
{
core_ops_control_flow_ControlFlow_19 uu____0 = core_result_branch_71_e9(issue_105_inner());
if (!(uu____0.tag == core_ops_control_flow_Continue))
{
core_result_Result_8f residual = uu____0.f0;
return core_result_from_residual_1f_48(residual);
}
return (KRML_CLITERAL(core_result_Result_1d){ .tag = core_result_Ok });
}
/**
This function found in impl {core::cmp::PartialEq[TraitClause@0, TraitClause@1]> for core::result::Result[TraitClause@0, TraitClause@1]}
*/
/**
A monomorphic instance of core.result.eq_0b
with types (), uint8_t
with const generics
*/
inline bool
core_result_eq_0b_74(const core_result_Result_1d *self, const core_result_Result_1d *other)
{
ptrdiff_t __self_discr = (ptrdiff_t)self->tag;
ptrdiff_t __arg1_discr = (ptrdiff_t)other->tag;
bool uu____0;
if (__self_discr == __arg1_discr)
{
if (self->tag == core_result_Ok)
{
EURYDICE_ASSERT(!!((ptrdiff_t)other->tag == (ptrdiff_t)0), "assert failure");
/* original Rust expression is not an lvalue in C */
void *lvalue0 = (void *)0U;
void *const *__self_0 = &lvalue0;
/* original Rust expression is not an lvalue in C */
void *lvalue = (void *)0U;
void *const *__arg1_0 = &lvalue;
uu____0 = core_cmp_impls_eq_cf(__self_0, __arg1_0);
}
else
{
EURYDICE_ASSERT(!!((ptrdiff_t)other->tag == (ptrdiff_t)1), "assert failure");
const uint8_t *__self_0 = &self->f0;
const uint8_t *__arg1_0 = &other->f0;
uu____0 = core_cmp_impls_eq_c3(__self_0, __arg1_0);
}
}
else
{
uu____0 = false;
}
return uu____0;
}
typedef struct const_core_result_Result_1d__x2_s
{
const core_result_Result_1d *fst;
const core_result_Result_1d *snd;
}
const_core_result_Result_1d__x2;
void issue_105_main(void)
{
/* original Rust expression is not an lvalue in C */
core_result_Result_1d lvalue0 = issue_105_call_it();
/* original Rust expression is not an lvalue in C */
core_result_Result_1d lvalue = { .tag = core_result_Err, .f0 = 1U };
const_core_result_Result_1d__x2 uu____0 = { .fst = &lvalue0, .snd = &lvalue };
EURYDICE_ASSERT(core_result_eq_0b_74(uu____0.fst, uu____0.snd), "panic!");
}
================================================
FILE: out/test-issue_105/issue_105.h
================================================
/*
This file was generated by KaRaMeL
F* version:
*/
#ifndef issue_105_H
#define issue_105_H
#include "eurydice_glue.h"
#if defined(__cplusplus)
extern "C" {
#endif
/**
This function found in impl {core::cmp::PartialEq<()> for ()}
*/
bool core_cmp_impls_eq_cf(void *const *self, void *const *_other);
/**
This function found in impl {core::cmp::PartialEq<()> for ()}
*/
bool core_cmp_impls_ne_cf(void *const *self, void *const *_other);
/**
This function found in impl {core::cmp::PartialEq for u8}
*/
bool core_cmp_impls_eq_c3(const uint8_t *self, const uint8_t *other);
/**
This function found in impl {core::cmp::PartialEq for u8}
*/
bool core_cmp_impls_ne_c3(const uint8_t *self, const uint8_t *other);
typedef uint8_t core_convert_Infallible;
#define core_panicking_AssertKind_Eq 0
#define core_panicking_AssertKind_Ne 1
#define core_panicking_AssertKind_Match 2
typedef uint8_t core_panicking_AssertKind;
#define core_result_Ok 0
#define core_result_Err 1
typedef uint8_t core_result_Result_1d_tags;
/**
A monomorphic instance of core.result.Result
with types (), uint8_t
*/
typedef struct core_result_Result_1d_s
{
core_result_Result_1d_tags tag;
uint8_t f0;
}
core_result_Result_1d;
core_result_Result_1d issue_105_inner(void);
/**
A monomorphic instance of core.result.Result
with types core_convert_Infallible, uint8_t
*/
typedef struct core_result_Result_8f_s
{
core_result_Result_1d_tags tag;
union {
core_convert_Infallible case_Ok;
uint8_t case_Err;
}
val;
}
core_result_Result_8f;
#define core_ops_control_flow_Continue 0
#define core_ops_control_flow_Break 1
typedef uint8_t core_ops_control_flow_ControlFlow_19_tags;
/**
A monomorphic instance of core.ops.control_flow.ControlFlow
with types core_result_Result_8f, ()
*/
typedef struct core_ops_control_flow_ControlFlow_19_s
{
core_ops_control_flow_ControlFlow_19_tags tag;
core_result_Result_8f f0;
}
core_ops_control_flow_ControlFlow_19;
/**
This function found in impl {core::ops::try_trait::Try[core::marker::Sized